1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Casing
; use Casing
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Errout
; use Errout
;
32 with Exp_Ch7
; use Exp_Ch7
;
33 with Exp_Util
; use Exp_Util
;
34 with Hostparm
; use Hostparm
;
35 with Inline
; use Inline
;
37 with Namet
; use Namet
;
38 with Nlists
; use Nlists
;
39 with Nmake
; use Nmake
;
41 with Rtsfind
; use Rtsfind
;
42 with Restrict
; use Restrict
;
44 with Sem_Ch5
; use Sem_Ch5
;
45 with Sem_Ch8
; use Sem_Ch8
;
46 with Sem_Res
; use Sem_Res
;
47 with Sem_Util
; use Sem_Util
;
48 with Sinfo
; use Sinfo
;
49 with Sinput
; use Sinput
;
50 with Snames
; use Snames
;
51 with Stand
; use Stand
;
52 with Stringt
; use Stringt
;
53 with Targparm
; use Targparm
;
54 with Tbuild
; use Tbuild
;
55 with Uintp
; use Uintp
;
56 with Uname
; use Uname
;
58 package body Exp_Ch11
is
61 -- This list gathers the values SDn'Unrestricted_Access used to
62 -- construct the unit exception table. It is set to Empty_List if
63 -- there are no subprogram descriptors.
65 -----------------------
66 -- Local Subprograms --
67 -----------------------
69 procedure Expand_Exception_Handler_Tables
(HSS
: Node_Id
);
70 -- Subsidiary procedure called by Expand_Exception_Handlers if zero
71 -- cost exception handling is installed for this target. Replaces the
72 -- exception handler structure with appropriate labeled code and tables
73 -- that allow the zero cost exception handling circuits to find the
74 -- correct handler (see unit Ada.Exceptions for details).
76 procedure Generate_Subprogram_Descriptor
81 -- Procedure called to generate a subprogram descriptor. N is the
82 -- subprogram body node or, in the case of an imported subprogram, is
83 -- Empty, and Spec is the entity of the sunprogram. For details of the
84 -- required structure, see package System.Exceptions. The generated
85 -- subprogram descriptor is appended to Slist. Loc provides the
86 -- source location to be used for the generated descriptor.
88 ---------------------------
89 -- Expand_At_End_Handler --
90 ---------------------------
92 -- For a handled statement sequence that has a cleanup (At_End_Proc
93 -- field set), an exception handler of the following form is required:
100 -- Note: this exception handler is treated rather specially by
101 -- subsequent expansion in two respects:
103 -- The normal call to Undefer_Abort is omitted
104 -- The raise call does not do Defer_Abort
106 -- This is because the current tasking code seems to assume that
107 -- the call to the cleanup routine that is made from an exception
108 -- handler for the abort signal is called with aborts deferred.
110 procedure Expand_At_End_Handler
(HSS
: Node_Id
; Block
: Node_Id
) is
111 Clean
: constant Entity_Id
:= Entity
(At_End_Proc
(HSS
));
112 Loc
: constant Source_Ptr
:= Sloc
(Clean
);
117 pragma Assert
(Present
(Clean
));
118 pragma Assert
(No
(Exception_Handlers
(HSS
)));
120 if Restrictions
(No_Exception_Handlers
) then
124 if Present
(Block
) then
129 Make_Others_Choice
(Loc
);
130 Set_All_Others
(Ohandle
);
133 Make_Procedure_Call_Statement
(Loc
,
134 Name
=> New_Occurrence_Of
(Clean
, Loc
)),
135 Make_Raise_Statement
(Loc
));
137 Set_Exception_Handlers
(HSS
, New_List
(
138 Make_Exception_Handler
(Loc
,
139 Exception_Choices
=> New_List
(Ohandle
),
140 Statements
=> Stmnts
)));
142 Analyze_List
(Stmnts
, Suppress
=> All_Checks
);
143 Expand_Exception_Handlers
(HSS
);
145 if Present
(Block
) then
148 end Expand_At_End_Handler
;
150 -------------------------------------
151 -- Expand_Exception_Handler_Tables --
152 -------------------------------------
154 -- See Ada.Exceptions specification for full details of the data
155 -- structures that we need to construct here. As an example of the
156 -- transformation that is required, given the structure:
173 -- We transform this into:
195 -- HR2 : constant Handler_Record := (
199 -- Handler => L5'Address);
201 -- HR3 : constant Handler_Record := (
205 -- Handler => L4'Address);
211 -- HR1 : constant Handler_Record := (
215 -- Handler => L4'Address);
218 -- The exception handlers in the transformed version are marked with the
219 -- Zero_Cost_Handling flag set, and all gigi does in this case is simply
220 -- to put the handler code somewhere. It can optionally be put inline
221 -- between the goto L3 and the label <<L3>> (which is why we generate
222 -- that goto in the first place).
224 procedure Expand_Exception_Handler_Tables
(HSS
: Node_Id
) is
225 Loc
: constant Source_Ptr
:= Sloc
(HSS
);
226 Handlrs
: constant List_Id
:= Exception_Handlers
(HSS
);
227 Stms
: constant List_Id
:= Statements
(HSS
);
231 -- This is the list to which handlers are to be appended. It is
232 -- either the list for the enclosing subprogram, or the enclosing
233 -- selective accept statement (which will turn into a subprogram
234 -- during expansion later on).
236 L1
: constant Entity_Id
:=
237 Make_Defining_Identifier
(Loc
,
238 Chars
=> New_Internal_Name
('L'));
240 L2
: constant Entity_Id
:=
241 Make_Defining_Identifier
(Loc
,
242 Chars
=> New_Internal_Name
('L'));
251 Subp_Entity
: Entity_Id
;
252 -- This is the entity for the subprogram (or library level package)
253 -- to which the handler record is to be attached for later reference
254 -- in a subprogram descriptor for this entity.
256 procedure Append_To_Stms
(N
: Node_Id
);
257 -- Append given statement to the end of the statements of the
258 -- handled sequence of statements and analyze it in place.
260 function Inside_Selective_Accept
return Boolean;
261 -- This function is called if we are inside the scope of an entry
262 -- or task. It checks if the handler is appearing in the context
263 -- of a selective accept statement. If so, Hlist is set to
264 -- temporarily park the handlers in the N_Accept_Alternative.
265 -- node. They will subsequently be moved to the procedure entity
266 -- for the procedure built for this alternative. The statements that
267 -- follow the Accept within the alternative are not inside the Accept
268 -- for purposes of this test, and handlers that may appear within
269 -- them belong in the enclosing task procedure.
272 -- Sets the handler list corresponding to Subp_Entity
278 procedure Append_To_Stms
(N
: Node_Id
) is
280 Insert_After_And_Analyze
(Last
(Stms
), N
);
281 Set_Exception_Junk
(N
);
284 -----------------------------
285 -- Inside_Selective_Accept --
286 -----------------------------
288 function Inside_Selective_Accept
return Boolean is
290 Curr
: Node_Id
:= HSS
;
293 Parnt
:= Parent
(HSS
);
294 while Nkind
(Parnt
) /= N_Compilation_Unit
loop
295 if Nkind
(Parnt
) = N_Accept_Alternative
296 and then Curr
= Accept_Statement
(Parnt
)
298 if Present
(Accept_Handler_Records
(Parnt
)) then
299 Hlist
:= Accept_Handler_Records
(Parnt
);
302 Set_Accept_Handler_Records
(Parnt
, Hlist
);
308 Parnt
:= Parent
(Parnt
);
313 end Inside_Selective_Accept
;
319 procedure Set_Hlist
is
321 -- Never try to inline a subprogram with exception handlers
323 Set_Is_Inlined
(Subp_Entity
, False);
325 if Present
(Subp_Entity
)
326 and then Present
(Handler_Records
(Subp_Entity
))
328 Hlist
:= Handler_Records
(Subp_Entity
);
331 Set_Handler_Records
(Subp_Entity
, Hlist
);
335 -- Start of processing for Expand_Exception_Handler_Tables
338 -- Nothing to do if this handler has already been processed
340 if Zero_Cost_Handling
(HSS
) then
344 Set_Zero_Cost_Handling
(HSS
);
346 -- Find the parent subprogram or package scope containing this
347 -- exception frame. This should always find a real package or
348 -- subprogram. If it does not it will stop at Standard, but
349 -- this cannot legitimately occur.
351 -- We only stop at library level packages, for inner packages
352 -- we always attach handlers to the containing procedure.
354 Subp_Entity
:= Current_Scope
;
357 -- Never need tables expanded inside a generic template
359 if Is_Generic_Unit
(Subp_Entity
) then
362 -- Stop if we reached containing subprogram. Go to protected
363 -- subprogram if there is one defined.
365 elsif Ekind
(Subp_Entity
) = E_Function
366 or else Ekind
(Subp_Entity
) = E_Procedure
368 if Present
(Protected_Body_Subprogram
(Subp_Entity
)) then
369 Subp_Entity
:= Protected_Body_Subprogram
(Subp_Entity
);
375 -- Case of within an entry
377 elsif Is_Entry
(Subp_Entity
) then
379 -- Protected entry, use corresponding body subprogram
381 if Present
(Protected_Body_Subprogram
(Subp_Entity
)) then
382 Subp_Entity
:= Protected_Body_Subprogram
(Subp_Entity
);
386 -- Check if we are within a selective accept alternative
388 elsif Inside_Selective_Accept
then
390 -- As a side effect, Inside_Selective_Accept set Hlist,
391 -- in much the same manner as Set_Hlist, except that
392 -- the list involved was the one for the selective accept.
397 -- Case of within library level package
399 elsif Ekind
(Subp_Entity
) = E_Package
400 and then Is_Compilation_Unit
(Subp_Entity
)
402 if Is_Body_Name
(Unit_Name
(Get_Code_Unit
(HSS
))) then
403 Subp_Entity
:= Body_Entity
(Subp_Entity
);
411 elsif Ekind
(Subp_Entity
) = E_Task_Type
then
413 -- Check if we are within a selective accept alternative
415 if Inside_Selective_Accept
then
417 -- As a side effect, Inside_Selective_Accept set Hlist,
418 -- in much the same manner as Set_Hlist, except that the
419 -- list involved was the one for the selective accept.
423 -- Stop if we reached task type with task body procedure,
424 -- use the task body procedure.
426 elsif Present
(Get_Task_Body_Procedure
(Subp_Entity
)) then
427 Subp_Entity
:= Get_Task_Body_Procedure
(Subp_Entity
);
433 -- If we fall through, keep looking
435 Subp_Entity
:= Scope
(Subp_Entity
);
438 pragma Assert
(Subp_Entity
/= Standard_Standard
);
440 -- Analyze standard labels
442 Analyze_Label_Entity
(L1
);
443 Analyze_Label_Entity
(L2
);
445 Insert_Before_And_Analyze
(First
(Stms
),
447 Identifier
=> New_Occurrence_Of
(L1
, Loc
)));
448 Set_Exception_Junk
(First
(Stms
));
452 Identifier
=> New_Occurrence_Of
(L2
, Loc
)));
454 -- Loop through exception handlers
456 Handler
:= First_Non_Pragma
(Handlrs
);
457 while Present
(Handler
) loop
458 Set_Zero_Cost_Handling
(Handler
);
460 -- Add label at start of handler, and goto at the end
463 Make_Defining_Identifier
(Loc
,
464 Chars
=> New_Internal_Name
('L'));
466 Analyze_Label_Entity
(Lnn
);
470 Identifier
=> New_Occurrence_Of
(Lnn
, Loc
));
471 Set_Exception_Junk
(Item
);
472 Insert_Before_And_Analyze
(First
(Statements
(Handler
)), Item
);
474 -- Loop through choices
476 Choice
:= First
(Exception_Choices
(Handler
));
477 while Present
(Choice
) loop
479 -- Others (or all others) choice
481 if Nkind
(Choice
) = N_Others_Choice
then
482 if All_Others
(Choice
) then
483 E_Id
:= New_Occurrence_Of
(RTE
(RE_All_Others_Id
), Loc
);
485 E_Id
:= New_Occurrence_Of
(RTE
(RE_Others_Id
), Loc
);
488 -- Special case of VMS_Exception. Not clear what we will do
489 -- eventually here if and when we implement zero cost exceptions
490 -- on VMS. But at least for now, don't blow up trying to take
491 -- a garbage code address for such an exception.
493 elsif Is_VMS_Exception
(Entity
(Choice
)) then
494 E_Id
:= New_Occurrence_Of
(RTE
(RE_Null_Id
), Loc
);
496 -- Normal case of specific exception choice
500 Make_Attribute_Reference
(Loc
,
501 Prefix
=> New_Occurrence_Of
(Entity
(Choice
), Loc
),
502 Attribute_Name
=> Name_Identity
);
506 Make_Defining_Identifier
(Loc
,
507 Chars
=> New_Internal_Name
('H'));
510 Make_Attribute_Reference
(Loc
,
511 Prefix
=> New_Occurrence_Of
(HR_Ent
, Loc
),
512 Attribute_Name
=> Name_Unrestricted_Access
);
514 -- Now we need to add the entry for the new handler record to
515 -- the list of handler records for the current subprogram.
517 -- Normally we end up generating the handler records in exactly
518 -- the right order. Here right order means innermost first,
519 -- since the table will be searched sequentially. Since we
520 -- generally expand from outside to inside, the order is just
521 -- what we want, and we need to append the new entry to the
524 -- However, there are exceptions, notably in the case where
525 -- a generic body is inserted later on. See for example the
526 -- case of ACVC test C37213J, which has the following form:
528 -- generic package x ... end x;
539 -- package q is new x;
546 -- In this case, we will expand exception handler (2) first,
547 -- since the expansion of (1) is delayed till later when the
548 -- generic body is inserted. But (1) belongs before (2) in
551 -- Note that scopes are not totally ordered, because two
552 -- scopes can be in parallel blocks, so that it does not
553 -- matter what order these entries appear in. An ordering
554 -- relation exists if one scope is inside another, and what
555 -- we really want is some partial ordering.
557 -- A simple, not very efficient, but adequate algorithm to
558 -- achieve this partial ordering is to search the list for
559 -- the first entry containing the given scope, and put the
560 -- new entry just before it.
563 New_Scop
: constant Entity_Id
:= Current_Scope
;
567 Ent
:= First
(Hlist
);
569 -- If all searched, then we can just put the new
570 -- entry at the end of the list (it actually does
571 -- not matter where we put it in this case).
574 Append_To
(Hlist
, HL_Ref
);
577 -- If the current scope is within the scope of the
578 -- entry then insert the entry before to retain the
579 -- proper order as per above discussion.
581 -- Note that for equal entries, we just keep going,
582 -- which is fine, the entry will end up at the end
583 -- of the list where it belongs.
586 (New_Scop
, Scope
(Entity
(Prefix
(Ent
))))
588 Insert_Before
(Ent
, HL_Ref
);
591 -- Otherwise keep looking
600 Make_Object_Declaration
(Loc
,
601 Defining_Identifier
=> HR_Ent
,
602 Constant_Present
=> True,
603 Aliased_Present
=> True,
605 New_Occurrence_Of
(RTE
(RE_Handler_Record
), Loc
),
609 Expressions
=> New_List
(
610 Make_Attribute_Reference
(Loc
, -- Lo
611 Prefix
=> New_Occurrence_Of
(L1
, Loc
),
612 Attribute_Name
=> Name_Address
),
614 Make_Attribute_Reference
(Loc
, -- Hi
615 Prefix
=> New_Occurrence_Of
(L2
, Loc
),
616 Attribute_Name
=> Name_Address
),
620 Make_Attribute_Reference
(Loc
,
621 Prefix
=> New_Occurrence_Of
(Lnn
, Loc
), -- Handler
622 Attribute_Name
=> Name_Address
))));
624 Set_Handler_List_Entry
(Item
, HL_Ref
);
625 Set_Exception_Junk
(Item
);
626 Insert_After_And_Analyze
(Last
(Statements
(Handler
)), Item
);
627 Set_Is_Statically_Allocated
(HR_Ent
);
629 -- If this is a late insertion (from body instance) it is being
630 -- inserted in the component list of an already analyzed aggre-
631 -- gate, and must be analyzed explicitly.
633 Analyze_And_Resolve
(HL_Ref
, RTE
(RE_Handler_Record_Ptr
));
638 Next_Non_Pragma
(Handler
);
640 end Expand_Exception_Handler_Tables
;
642 -------------------------------
643 -- Expand_Exception_Handlers --
644 -------------------------------
646 procedure Expand_Exception_Handlers
(HSS
: Node_Id
) is
647 Handlrs
: constant List_Id
:= Exception_Handlers
(HSS
);
650 Others_Choice
: Boolean;
653 procedure Prepend_Call_To_Handler
655 Args
: List_Id
:= No_List
);
656 -- Routine to prepend a call to the procedure referenced by Proc at
657 -- the start of the handler code for the current Handler.
659 -----------------------------
660 -- Prepend_Call_To_Handler --
661 -----------------------------
663 procedure Prepend_Call_To_Handler
665 Args
: List_Id
:= No_List
)
667 Ent
: constant Entity_Id
:= RTE
(Proc
);
670 -- If we have no Entity, then we are probably in no run time mode
671 -- or some weird error has occured. In either case do do nothing!
673 if Present
(Ent
) then
675 Call
: constant Node_Id
:=
676 Make_Procedure_Call_Statement
(Loc
,
677 Name
=> New_Occurrence_Of
(RTE
(Proc
), Loc
),
678 Parameter_Associations
=> Args
);
681 Prepend_To
(Statements
(Handler
), Call
);
682 Analyze
(Call
, Suppress
=> All_Checks
);
685 end Prepend_Call_To_Handler
;
687 -- Start of processing for Expand_Exception_Handlers
690 -- Loop through handlers
692 Handler
:= First_Non_Pragma
(Handlrs
);
693 while Present
(Handler
) loop
694 Loc
:= Sloc
(Handler
);
696 -- If an exception occurrence is present, then we must declare it
697 -- and initialize it from the value stored in the TSD
700 -- name : Exception_Occurrence;
703 -- Save_Occurrence (name, Get_Current_Excep.all)
707 if Present
(Choice_Parameter
(Handler
)) then
709 Cparm
: constant Entity_Id
:= Choice_Parameter
(Handler
);
710 Clc
: constant Source_Ptr
:= Sloc
(Cparm
);
715 Make_Procedure_Call_Statement
(Loc
,
717 New_Occurrence_Of
(RTE
(RE_Save_Occurrence
), Loc
),
718 Parameter_Associations
=> New_List
(
719 New_Occurrence_Of
(Cparm
, Clc
),
720 Make_Explicit_Dereference
(Loc
,
721 Make_Function_Call
(Loc
,
722 Name
=> Make_Explicit_Dereference
(Loc
,
724 (RTE
(RE_Get_Current_Excep
), Loc
))))));
726 Mark_Rewrite_Insertion
(Save
);
727 Prepend
(Save
, Statements
(Handler
));
730 Make_Object_Declaration
(Clc
,
731 Defining_Identifier
=> Cparm
,
734 (RTE
(RE_Exception_Occurrence
), Clc
));
735 Set_No_Initialization
(Obj_Decl
, True);
738 Make_Exception_Handler
(Loc
,
739 Exception_Choices
=> Exception_Choices
(Handler
),
741 Statements
=> New_List
(
742 Make_Block_Statement
(Loc
,
743 Declarations
=> New_List
(Obj_Decl
),
744 Handled_Statement_Sequence
=>
745 Make_Handled_Sequence_Of_Statements
(Loc
,
746 Statements
=> Statements
(Handler
))))));
748 Analyze_List
(Statements
(Handler
), Suppress
=> All_Checks
);
752 -- The processing at this point is rather different for the
753 -- JVM case, so we completely separate the processing.
755 -- For the JVM case, we unconditionally call Update_Exception,
756 -- passing a call to the intrinsic function Current_Target_Exception
757 -- (see JVM version of Ada.Exceptions in 4jexcept.adb for details).
759 if Hostparm
.Java_VM
then
762 := Make_Function_Call
(Loc
,
763 Name
=> New_Occurrence_Of
764 (RTE
(RE_Current_Target_Exception
), Loc
));
766 Prepend_Call_To_Handler
(RE_Update_Exception
, New_List
(Arg
));
769 -- For the normal case, we have to worry about the state of abort
770 -- deferral. Generally, we defer abort during runtime handling of
771 -- exceptions. When control is passed to the handler, then in the
772 -- normal case we undefer aborts. In any case this entire handling
773 -- is relevant only if aborts are allowed!
775 elsif Abort_Allowed
then
777 -- There are some special cases in which we do not do the
778 -- undefer. In particular a finalization (AT END) handler
779 -- wants to operate with aborts still deferred.
781 -- We also suppress the call if this is the special handler
782 -- for Abort_Signal, since if we are aborting, we want to keep
783 -- aborts deferred (one abort is enough thank you very much :-)
785 -- If abort really needs to be deferred the expander must add
786 -- this call explicitly, see Exp_Ch9.Expand_N_Asynchronous_Select.
789 Nkind
(First
(Exception_Choices
(Handler
))) = N_Others_Choice
;
792 or else Entity
(First
(Exception_Choices
(Handler
))) /=
796 and then All_Others
(First
(Exception_Choices
(Handler
))))
797 and then Abort_Allowed
799 Prepend_Call_To_Handler
(RE_Abort_Undefer
);
803 Next_Non_Pragma
(Handler
);
806 -- The last step for expanding exception handlers is to expand the
807 -- exception tables if zero cost exception handling is active.
809 if Exception_Mechanism
= Front_End_ZCX
then
810 Expand_Exception_Handler_Tables
(HSS
);
812 end Expand_Exception_Handlers
;
814 ------------------------------------
815 -- Expand_N_Exception_Declaration --
816 ------------------------------------
819 -- exceptE : constant String := "A.B.EXCEP"; -- static data
820 -- except : exception_data := (
821 -- Handled_By_Other => False,
823 -- Name_Length => exceptE'Length
824 -- Full_Name => exceptE'Address
825 -- HTable_Ptr => null);
827 -- (protecting test only needed if not at library level)
829 -- exceptF : Boolean := True -- static data
832 -- Register_Exception (except'Unchecked_Access);
835 procedure Expand_N_Exception_Declaration
(N
: Node_Id
) is
836 Loc
: constant Source_Ptr
:= Sloc
(N
);
837 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
838 L
: List_Id
:= New_List
;
841 Name_Exname
: constant Name_Id
:= New_External_Name
(Chars
(Id
), 'E');
842 Exname
: constant Node_Id
:=
843 Make_Defining_Identifier
(Loc
, Name_Exname
);
846 -- There is no expansion needed when compiling for the JVM since the
847 -- JVM has a built-in exception mechanism. See 4jexcept.ads for details.
849 if Hostparm
.Java_VM
then
853 -- Definition of the external name: nam : constant String := "A.B.NAME";
856 Make_Object_Declaration
(Loc
,
857 Defining_Identifier
=> Exname
,
858 Constant_Present
=> True,
859 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
860 Expression
=> Make_String_Literal
(Loc
, Full_Qualified_Name
(Id
))));
862 Set_Is_Statically_Allocated
(Exname
);
864 -- Create the aggregate list for type Standard.Exception_Type:
865 -- Handled_By_Other component: False
867 Append_To
(L
, New_Occurrence_Of
(Standard_False
, Loc
));
869 -- Lang component: 'A'
872 Make_Character_Literal
(Loc
, Name_uA
, Get_Char_Code
('A')));
874 -- Name_Length component: Nam'Length
877 Make_Attribute_Reference
(Loc
,
878 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
879 Attribute_Name
=> Name_Length
));
881 -- Full_Name component: Standard.A_Char!(Nam'Address)
883 Append_To
(L
, Unchecked_Convert_To
(Standard_A_Char
,
884 Make_Attribute_Reference
(Loc
,
885 Prefix
=> New_Occurrence_Of
(Exname
, Loc
),
886 Attribute_Name
=> Name_Address
)));
888 -- HTable_Ptr component: null
890 Append_To
(L
, Make_Null
(Loc
));
892 -- Import_Code component: 0
894 Append_To
(L
, Make_Integer_Literal
(Loc
, 0));
896 Set_Expression
(N
, Make_Aggregate
(Loc
, Expressions
=> L
));
897 Analyze_And_Resolve
(Expression
(N
), Etype
(Id
));
899 -- Register_Exception (except'Unchecked_Access);
901 if not Restrictions
(No_Exception_Handlers
) then
903 Make_Procedure_Call_Statement
(Loc
,
904 Name
=> New_Occurrence_Of
(RTE
(RE_Register_Exception
), Loc
),
905 Parameter_Associations
=> New_List
(
906 Unchecked_Convert_To
(RTE
(RE_Exception_Data_Ptr
),
907 Make_Attribute_Reference
(Loc
,
908 Prefix
=> New_Occurrence_Of
(Id
, Loc
),
909 Attribute_Name
=> Name_Unrestricted_Access
)))));
911 Set_Register_Exception_Call
(Id
, First
(L
));
913 if not Is_Library_Level_Entity
(Id
) then
914 Flag_Id
:= Make_Defining_Identifier
(Loc
,
915 New_External_Name
(Chars
(Id
), 'F'));
918 Make_Object_Declaration
(Loc
,
919 Defining_Identifier
=> Flag_Id
,
921 New_Occurrence_Of
(Standard_Boolean
, Loc
),
923 New_Occurrence_Of
(Standard_True
, Loc
)));
925 Set_Is_Statically_Allocated
(Flag_Id
);
928 Make_Assignment_Statement
(Loc
,
929 Name
=> New_Occurrence_Of
(Flag_Id
, Loc
),
930 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
932 Insert_After_And_Analyze
(N
,
933 Make_Implicit_If_Statement
(N
,
934 Condition
=> New_Occurrence_Of
(Flag_Id
, Loc
),
935 Then_Statements
=> L
));
938 Insert_List_After_And_Analyze
(N
, L
);
942 end Expand_N_Exception_Declaration
;
944 ---------------------------------------------
945 -- Expand_N_Handled_Sequence_Of_Statements --
946 ---------------------------------------------
948 procedure Expand_N_Handled_Sequence_Of_Statements
(N
: Node_Id
) is
950 if Present
(Exception_Handlers
(N
))
951 and then not Restrictions
(No_Exception_Handlers
)
953 Expand_Exception_Handlers
(N
);
956 -- The following code needs comments ???
958 if Nkind
(Parent
(N
)) /= N_Package_Body
959 and then Nkind
(Parent
(N
)) /= N_Accept_Statement
960 and then not Delay_Cleanups
(Current_Scope
)
962 Expand_Cleanup_Actions
(Parent
(N
));
964 Set_First_Real_Statement
(N
, First
(Statements
(N
)));
967 end Expand_N_Handled_Sequence_Of_Statements
;
969 -------------------------------------
970 -- Expand_N_Raise_Constraint_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_Constraint_Error
(N
: Node_Id
) is
981 Adjust_Condition
(Condition
(N
));
982 end Expand_N_Raise_Constraint_Error
;
984 ----------------------------------
985 -- Expand_N_Raise_Program_Error --
986 ----------------------------------
988 -- The only processing required is to adjust the condition to deal
989 -- with the C/Fortran boolean case. This may well not be necessary,
990 -- as all such conditions are generated by the expander and probably
991 -- are all standard boolean, but who knows what strange optimization
992 -- in future may require this adjustment!
994 procedure Expand_N_Raise_Program_Error
(N
: Node_Id
) is
996 Adjust_Condition
(Condition
(N
));
997 end Expand_N_Raise_Program_Error
;
999 ------------------------------
1000 -- Expand_N_Raise_Statement --
1001 ------------------------------
1003 procedure Expand_N_Raise_Statement
(N
: Node_Id
) is
1004 Loc
: constant Source_Ptr
:= Sloc
(N
);
1010 -- There is no expansion needed for statement "raise <exception>;" when
1011 -- compiling for the JVM since the JVM has a built-in exception
1012 -- mechanism. However we need the keep the expansion for "raise;"
1013 -- statements. See 4jexcept.ads for details.
1015 if Present
(Name
(N
)) and then Hostparm
.Java_VM
then
1019 -- Convert explicit raise of Program_Error, Constraint_Error, and
1020 -- Storage_Error into the corresponding raise node (in No_Run_Time
1021 -- mode all other raises will get normal expansion and be disallowed,
1022 -- but this is also faster in all modes).
1024 if Present
(Name
(N
)) and then Nkind
(Name
(N
)) = N_Identifier
then
1025 if Entity
(Name
(N
)) = Standard_Constraint_Error
then
1027 Make_Raise_Constraint_Error
(Loc
,
1028 Reason
=> CE_Explicit_Raise
));
1032 elsif Entity
(Name
(N
)) = Standard_Program_Error
then
1034 Make_Raise_Program_Error
(Loc
,
1035 Reason
=> PE_Explicit_Raise
));
1039 elsif Entity
(Name
(N
)) = Standard_Storage_Error
then
1041 Make_Raise_Storage_Error
(Loc
,
1042 Reason
=> SE_Explicit_Raise
));
1048 -- Case of name present, in this case we expand raise name to
1050 -- Raise_Exception (name'Identity, location_string);
1052 -- where location_string identifies the file/line of the raise
1054 if Present
(Name
(N
)) then
1056 Id
: Entity_Id
:= Entity
(Name
(N
));
1059 Build_Location_String
(Loc
);
1061 -- If the exception is a renaming, use the exception that it
1062 -- renames (which might be a predefined exception, e.g.).
1064 if Present
(Renamed_Object
(Id
)) then
1065 Id
:= Renamed_Object
(Id
);
1068 -- Build a C compatible string in case of no exception handlers,
1069 -- since this is what the last chance handler is expecting.
1071 if Restrictions
(No_Exception_Handlers
) then
1072 -- Generate a C null message when Global_Discard_Names is True
1073 -- or when Debug_Flag_NN is set.
1075 if Global_Discard_Names
or else Debug_Flag_NN
then
1076 Name_Buffer
(1) := ASCII
.NUL
;
1079 Name_Len
:= Name_Len
+ 1;
1082 -- Do not generate the message when Global_Discard_Names is True
1083 -- or when Debug_Flag_NN is set.
1085 elsif Global_Discard_Names
or else Debug_Flag_NN
then
1089 Str
:= String_From_Name_Buffer
;
1091 -- For VMS exceptions, convert the raise into a call to
1092 -- lib$stop so it will be handled by __gnat_error_handler.
1094 if Is_VMS_Exception
(Id
) then
1096 Excep_Image
: String_Id
;
1100 if Present
(Interface_Name
(Id
)) then
1101 Excep_Image
:= Strval
(Interface_Name
(Id
));
1103 Get_Name_String
(Chars
(Id
));
1105 Excep_Image
:= String_From_Name_Buffer
;
1108 if Exception_Code
(Id
) /= No_Uint
then
1110 Make_Integer_Literal
(Loc
, Exception_Code
(Id
));
1113 Unchecked_Convert_To
(Standard_Integer
,
1114 Make_Function_Call
(Loc
,
1115 Name
=> New_Occurrence_Of
1116 (RTE
(RE_Import_Value
), Loc
),
1117 Parameter_Associations
=> New_List
1118 (Make_String_Literal
(Loc
,
1119 Strval
=> Excep_Image
))));
1123 Make_Procedure_Call_Statement
(Loc
,
1125 New_Occurrence_Of
(RTE
(RE_Lib_Stop
), Loc
),
1126 Parameter_Associations
=> New_List
(Cond
)));
1127 Analyze_And_Resolve
(Cond
, Standard_Integer
);
1130 -- Not VMS exception case, convert raise to call to the
1131 -- Raise_Exception routine.
1135 Make_Procedure_Call_Statement
(Loc
,
1136 Name
=> New_Occurrence_Of
(RTE
(RE_Raise_Exception
), Loc
),
1137 Parameter_Associations
=> New_List
(
1138 Make_Attribute_Reference
(Loc
,
1140 Attribute_Name
=> Name_Identity
),
1141 Make_String_Literal
(Loc
,
1146 -- Case of no name present (reraise). We rewrite the raise to:
1148 -- Reraise_Occurrence_Always (EO);
1150 -- where EO is the current exception occurrence. If the current handler
1151 -- does not have a choice parameter specification, then we provide one.
1154 -- Find innermost enclosing exception handler (there must be one,
1155 -- since the semantics has already verified that this raise statement
1156 -- is valid, and a raise with no arguments is only permitted in the
1157 -- context of an exception handler.
1159 Ehand
:= Parent
(N
);
1160 while Nkind
(Ehand
) /= N_Exception_Handler
loop
1161 Ehand
:= Parent
(Ehand
);
1164 -- Make exception choice parameter if none present. Note that we do
1165 -- not need to put the entity on the entity chain, since no one will
1166 -- be referencing this entity by normal visibility methods.
1168 if No
(Choice_Parameter
(Ehand
)) then
1169 E
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
1170 Set_Choice_Parameter
(Ehand
, E
);
1171 Set_Ekind
(E
, E_Variable
);
1172 Set_Etype
(E
, RTE
(RE_Exception_Occurrence
));
1173 Set_Scope
(E
, Current_Scope
);
1176 -- Now rewrite the raise as a call to Reraise. A special case arises
1177 -- if this raise statement occurs in the context of a handler for
1178 -- all others (i.e. an at end handler). in this case we avoid
1179 -- the call to defer abort, cleanup routines are expected to be
1180 -- called in this case with aborts deferred.
1183 Ech
: constant Node_Id
:= First
(Exception_Choices
(Ehand
));
1187 if Nkind
(Ech
) = N_Others_Choice
1188 and then All_Others
(Ech
)
1190 Ent
:= RTE
(RE_Reraise_Occurrence_No_Defer
);
1192 Ent
:= RTE
(RE_Reraise_Occurrence_Always
);
1196 Make_Procedure_Call_Statement
(Loc
,
1197 Name
=> New_Occurrence_Of
(Ent
, Loc
),
1198 Parameter_Associations
=> New_List
(
1199 New_Occurrence_Of
(Choice_Parameter
(Ehand
), Loc
))));
1204 end Expand_N_Raise_Statement
;
1206 ----------------------------------
1207 -- Expand_N_Raise_Storage_Error --
1208 ----------------------------------
1210 -- The only processing required is to adjust the condition to deal
1211 -- with the C/Fortran boolean case. This may well not be necessary,
1212 -- as all such conditions are generated by the expander and probably
1213 -- are all standard boolean, but who knows what strange optimization
1214 -- in future may require this adjustment!
1216 procedure Expand_N_Raise_Storage_Error
(N
: Node_Id
) is
1218 Adjust_Condition
(Condition
(N
));
1219 end Expand_N_Raise_Storage_Error
;
1221 ------------------------------
1222 -- Expand_N_Subprogram_Info --
1223 ------------------------------
1225 procedure Expand_N_Subprogram_Info
(N
: Node_Id
) is
1226 Loc
: constant Source_Ptr
:= Sloc
(N
);
1229 -- For now, we replace an Expand_N_Subprogram_Info node with an
1230 -- attribute reference that gives the address of the procedure.
1231 -- This is because gigi does not yet recognize this node, and
1232 -- for the initial targets, this is the right value anyway.
1235 Make_Attribute_Reference
(Loc
,
1236 Prefix
=> Identifier
(N
),
1237 Attribute_Name
=> Name_Code_Address
));
1239 Analyze_And_Resolve
(N
, RTE
(RE_Code_Loc
));
1240 end Expand_N_Subprogram_Info
;
1242 ------------------------------------
1243 -- Generate_Subprogram_Descriptor --
1244 ------------------------------------
1246 procedure Generate_Subprogram_Descriptor
1261 if Exception_Mechanism
/= Front_End_ZCX
then
1265 if Restrictions
(No_Exception_Handlers
) then
1269 -- Suppress descriptor if we are not generating code. This happens
1270 -- in the case of a -gnatc -gnatt compilation where we force generics
1271 -- to be generated, but we still don't want exception tables.
1273 if Operating_Mode
/= Generate_Code
then
1277 -- Suppress descriptor if we are in No_Exceptions restrictions mode,
1278 -- since we can never propagate exceptions in any case in this mode.
1279 -- The same consideration applies for No_Exception_Handlers (which
1280 -- is also set in No_Run_Time mode).
1282 if Restrictions
(No_Exceptions
)
1283 or Restrictions
(No_Exception_Handlers
)
1288 -- Suppress descriptor if we are inside a generic. There are two
1289 -- ways that we can tell that, depending on what is going on. If
1290 -- we are actually inside the processing for a generic right now,
1291 -- then Expander_Active will be reset. If we are outside the
1292 -- generic, then we will see the generic entity.
1294 if not Expander_Active
then
1298 -- Suppress descriptor is subprogram is marked as eliminated, for
1299 -- example if this is a subprogram created to analyze a default
1300 -- expression with potential side effects. Ditto if it is nested
1301 -- within an eliminated subprogram, for example a cleanup action.
1308 while Scop
/= Standard_Standard
loop
1309 if Ekind
(Scop
) = E_Generic_Procedure
1311 Ekind
(Scop
) = E_Generic_Function
1313 Ekind
(Scop
) = E_Generic_Package
1315 Is_Eliminated
(Scop
)
1320 Scop
:= Scope
(Scop
);
1324 -- Suppress descriptor for original protected subprogram (we will
1325 -- be called again later to generate the descriptor for the actual
1326 -- protected body subprogram.) This does not apply to barrier
1327 -- functions which are there own protected subprogram.
1329 if Is_Subprogram
(Spec
)
1330 and then Present
(Protected_Body_Subprogram
(Spec
))
1331 and then Protected_Body_Subprogram
(Spec
) /= Spec
1336 -- Suppress descriptors for packages unless they have at least one
1337 -- handler. The binder will generate the dummy (no handler) descriptors
1338 -- for elaboration procedures. We can't do it here, because we don't
1339 -- know if an elaboration routine does in fact exist.
1341 -- If there is at least one handler for the package spec or body
1342 -- then most certainly an elaboration routine must exist, so we
1343 -- can safely reference it.
1345 if (Nkind
(N
) = N_Package_Declaration
1347 Nkind
(N
) = N_Package_Body
)
1348 and then No
(Handler_Records
(Spec
))
1353 -- Suppress all subprogram descriptors for the file System.Exceptions.
1354 -- We similarly suppress subprogram descriptors for Ada.Exceptions.
1355 -- These are all init_proc's for types which cannot raise exceptions.
1356 -- The reason this is done is that otherwise we get embarassing
1357 -- elaboration dependencies.
1359 Get_Name_String
(Unit_File_Name
(Current_Sem_Unit
));
1361 if Name_Buffer
(1 .. 12) = "s-except.ads"
1363 Name_Buffer
(1 .. 12) = "a-except.ads"
1368 -- Similarly, we need to suppress entries for System.Standard_Library,
1369 -- since otherwise we get elaboration circularities. Again, this would
1370 -- better be done with a Suppress_Initialization pragma :-)
1372 if Name_Buffer
(1 .. 11) = "s-stalib.ad" then
1376 -- For now, also suppress entries for s-stoele because we have
1377 -- some kind of unexplained error there ???
1379 if Name_Buffer
(1 .. 11) = "s-stoele.ad" then
1383 -- And also for g-htable, because it cannot raise exceptions,
1384 -- and generates some kind of elaboration order problem.
1386 if Name_Buffer
(1 .. 11) = "g-htable.ad" then
1390 -- Suppress subprogram descriptor if already generated. This happens
1391 -- in the case of late generation from Delay_Subprogram_Descriptors
1392 -- beging set (where there is more than one instantiation in the list)
1394 if Has_Subprogram_Descriptor
(Spec
) then
1397 Set_Has_Subprogram_Descriptor
(Spec
);
1400 -- Never generate descriptors for inlined bodies
1402 if Analyzing_Inlined_Bodies
then
1406 -- Here we definitely are going to generate a subprogram descriptor
1409 Hnum
: Nat
:= Homonym_Number
(Spec
);
1417 Make_Defining_Identifier
(Loc
,
1418 Chars
=> New_External_Name
(Chars
(Spec
), "SD", Hnum
));
1421 if No
(Handler_Records
(Spec
)) then
1425 Hrc
:= Handler_Records
(Spec
);
1426 Numh
:= List_Length
(Hrc
);
1431 -- We need a static subtype for the declaration of the subprogram
1432 -- descriptor. For the case of 0-3 handlers we can use one of the
1433 -- predefined subtypes in System.Exceptions. For more handlers,
1434 -- we build our own subtype here.
1438 Dtyp
:= RTE
(RE_Subprogram_Descriptor_0
);
1441 Dtyp
:= RTE
(RE_Subprogram_Descriptor_1
);
1444 Dtyp
:= RTE
(RE_Subprogram_Descriptor_2
);
1447 Dtyp
:= RTE
(RE_Subprogram_Descriptor_3
);
1451 Make_Defining_Identifier
(Loc
,
1452 Chars
=> New_Internal_Name
('T'));
1454 -- Set the constructed type as global, since we will be
1455 -- referencing the object that is of this type globally
1457 Set_Is_Statically_Allocated
(Dtyp
);
1460 Make_Subtype_Declaration
(Loc
,
1461 Defining_Identifier
=> Dtyp
,
1462 Subtype_Indication
=>
1463 Make_Subtype_Indication
(Loc
,
1465 New_Occurrence_Of
(RTE
(RE_Subprogram_Descriptor
), Loc
),
1467 Make_Index_Or_Discriminant_Constraint
(Loc
,
1468 Constraints
=> New_List
(
1469 Make_Integer_Literal
(Loc
, Numh
)))));
1471 Append
(Decl
, Slist
);
1473 -- We analyze the descriptor for the subprogram and package
1474 -- case, but not for the imported subprogram case (it will
1475 -- be analyzed when the freeze entity actions are analyzed.
1481 Set_Exception_Junk
(Decl
);
1484 -- Prepare the code address entry for the table entry. For the normal
1485 -- case of being within a procedure, this is simply:
1489 -- where P is the procedure, but for the package case, it is
1491 -- P'Elab_Body'Code_Address
1492 -- P'Elab_Spec'Code_Address
1494 -- for the body and spec respectively. Note that we do our own
1495 -- analysis of these attribute references, because we know in this
1496 -- case that the prefix of ELab_Body/Spec is a visible package,
1497 -- which can be referenced directly instead of using the general
1498 -- case expansion for these attributes.
1500 if Ekind
(Spec
) = E_Package
then
1502 Make_Attribute_Reference
(Loc
,
1503 Prefix
=> New_Occurrence_Of
(Spec
, Loc
),
1504 Attribute_Name
=> Name_Elab_Spec
);
1505 Set_Etype
(Code
, Standard_Void_Type
);
1506 Set_Analyzed
(Code
);
1508 elsif Ekind
(Spec
) = E_Package_Body
then
1510 Make_Attribute_Reference
(Loc
,
1511 Prefix
=> New_Occurrence_Of
(Spec_Entity
(Spec
), Loc
),
1512 Attribute_Name
=> Name_Elab_Body
);
1513 Set_Etype
(Code
, Standard_Void_Type
);
1514 Set_Analyzed
(Code
);
1517 Code
:= New_Occurrence_Of
(Spec
, Loc
);
1521 Make_Attribute_Reference
(Loc
,
1523 Attribute_Name
=> Name_Code_Address
);
1525 Set_Etype
(Code
, RTE
(RE_Address
));
1526 Set_Analyzed
(Code
);
1528 -- Now we can build the subprogram descriptor
1531 Make_Object_Declaration
(Loc
,
1532 Defining_Identifier
=> Ent
,
1533 Constant_Present
=> True,
1534 Aliased_Present
=> True,
1535 Object_Definition
=> New_Occurrence_Of
(Dtyp
, Loc
),
1538 Make_Aggregate
(Loc
,
1539 Expressions
=> New_List
(
1540 Make_Integer_Literal
(Loc
, Numh
), -- Num_Handlers
1546 -- Make_Subprogram_Info (Loc, -- Subprogram_Info
1548 -- New_Occurrence_Of (Spec, Loc)),
1550 New_Copy_Tree
(Code
),
1552 Make_Aggregate
(Loc
, -- Handler_Records
1553 Expressions
=> Hrc
))));
1555 Set_Exception_Junk
(Sdes
);
1556 Set_Is_Subprogram_Descriptor
(Sdes
);
1558 Append
(Sdes
, Slist
);
1560 -- We analyze the descriptor for the subprogram and package case,
1561 -- but not for the imported subprogram case (it will be analyzed
1562 -- when the freeze entity actions are analyzed.
1568 -- We can now pop the scope used for analyzing the descriptor
1572 -- We need to set the descriptor as statically allocated, since
1573 -- it will be referenced from the unit exception table.
1575 Set_Is_Statically_Allocated
(Ent
);
1577 -- Append the resulting descriptor to the list. We do this only
1578 -- if we are in the main unit. You might think that we could
1579 -- simply skip generating the descriptors completely if we are
1580 -- not in the main unit, but in fact this is not the case, since
1581 -- we have problems with inconsistent serial numbers for internal
1582 -- names if we do this.
1584 if In_Extended_Main_Code_Unit
(Spec
) then
1586 Make_Attribute_Reference
(Loc
,
1587 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
1588 Attribute_Name
=> Name_Unrestricted_Access
));
1590 Unit_Exception_Table_Present
:= True;
1593 end Generate_Subprogram_Descriptor
;
1595 ------------------------------------------------------------
1596 -- Generate_Subprogram_Descriptor_For_Imported_Subprogram --
1597 ------------------------------------------------------------
1599 procedure Generate_Subprogram_Descriptor_For_Imported_Subprogram
1604 Generate_Subprogram_Descriptor
(Empty
, Sloc
(Spec
), Spec
, Slist
);
1605 end Generate_Subprogram_Descriptor_For_Imported_Subprogram
;
1607 ------------------------------------------------
1608 -- Generate_Subprogram_Descriptor_For_Package --
1609 ------------------------------------------------
1611 procedure Generate_Subprogram_Descriptor_For_Package
1618 -- If N is empty with prior errors, ignore
1620 if Total_Errors_Detected
/= 0 and then No
(N
) then
1624 -- Do not generate if no exceptions
1626 if Restrictions
(No_Exception_Handlers
) then
1630 -- Otherwise generate descriptor
1632 Adecl
:= Aux_Decls_Node
(Parent
(N
));
1634 if No
(Actions
(Adecl
)) then
1635 Set_Actions
(Adecl
, New_List
);
1638 Generate_Subprogram_Descriptor
(N
, Sloc
(N
), Spec
, Actions
(Adecl
));
1639 end Generate_Subprogram_Descriptor_For_Package
;
1641 ---------------------------------------------------
1642 -- Generate_Subprogram_Descriptor_For_Subprogram --
1643 ---------------------------------------------------
1645 procedure Generate_Subprogram_Descriptor_For_Subprogram
1650 -- If we have no subprogram body and prior errors, ignore
1652 if Total_Errors_Detected
/= 0 and then No
(N
) then
1656 -- Do not generate if no exceptions
1658 if Restrictions
(No_Exception_Handlers
) then
1662 -- Else generate descriptor
1665 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
1668 if No
(Exception_Handlers
(HSS
)) then
1669 Generate_Subprogram_Descriptor
1670 (N
, Sloc
(N
), Spec
, Statements
(HSS
));
1672 Generate_Subprogram_Descriptor
1674 Spec
, Statements
(Last
(Exception_Handlers
(HSS
))));
1677 end Generate_Subprogram_Descriptor_For_Subprogram
;
1679 -----------------------------------
1680 -- Generate_Unit_Exception_Table --
1681 -----------------------------------
1683 -- The only remaining thing to generate here is to generate the
1684 -- reference to the subprogram descriptor chain. See Ada.Exceptions
1685 -- for details of required data structures.
1687 procedure Generate_Unit_Exception_Table
is
1688 Loc
: constant Source_Ptr
:= No_Location
;
1692 Next_Ent
: Entity_Id
;
1696 -- Nothing to be done if zero length exceptions not active
1698 if Exception_Mechanism
/= Front_End_ZCX
then
1702 -- Nothing to do if no exceptions
1704 if Restrictions
(No_Exception_Handlers
) then
1708 -- Remove any entries from SD_List that correspond to eliminated
1711 Ent
:= First
(SD_List
);
1712 while Present
(Ent
) loop
1713 Next_Ent
:= Next
(Ent
);
1714 if Is_Eliminated
(Scope
(Entity
(Prefix
(Ent
)))) then
1715 Remove
(Ent
); -- After this, there is no Next (Ent) anymore
1721 -- Nothing to do if no unit exception table present.
1722 -- An empty table can result from subprogram elimination,
1723 -- in such a case, eliminate the exception table itself.
1725 if Is_Empty_List
(SD_List
) then
1726 Unit_Exception_Table_Present
:= False;
1730 -- Do not generate table in a generic
1732 if Inside_A_Generic
then
1736 -- Generate the unit exception table
1738 -- subtype Tnn is Subprogram_Descriptors_Record (Num);
1739 -- __gnat_unitname__SDP : aliased constant Tnn :=
1741 -- (sub1'unrestricted_access,
1742 -- sub2'unrestricted_access,
1744 -- subNum'unrestricted_access));
1746 Num
:= List_Length
(SD_List
);
1749 Make_Defining_Identifier
(Loc
,
1750 Chars
=> New_Internal_Name
('T'));
1752 Insert_Library_Level_Action
(
1753 Make_Subtype_Declaration
(Loc
,
1754 Defining_Identifier
=> Stent
,
1755 Subtype_Indication
=>
1756 Make_Subtype_Indication
(Loc
,
1759 (RTE
(RE_Subprogram_Descriptors_Record
), Loc
),
1761 Make_Index_Or_Discriminant_Constraint
(Loc
,
1762 Constraints
=> New_List
(
1763 Make_Integer_Literal
(Loc
, Num
))))));
1765 Set_Is_Statically_Allocated
(Stent
);
1767 Get_External_Unit_Name_String
(Unit_Name
(Main_Unit
));
1768 Name_Buffer
(1 + 7 .. Name_Len
+ 7) := Name_Buffer
(1 .. Name_Len
);
1769 Name_Buffer
(1 .. 7) := "__gnat_";
1770 Name_Len
:= Name_Len
+ 7;
1771 Add_Str_To_Name_Buffer
("__SDP");
1774 Make_Defining_Identifier
(Loc
,
1775 Chars
=> Name_Find
);
1777 Get_Name_String
(Chars
(Ent
));
1778 Set_Interface_Name
(Ent
,
1779 Make_String_Literal
(Loc
, Strval
=> String_From_Name_Buffer
));
1782 Make_Object_Declaration
(Loc
,
1783 Defining_Identifier
=> Ent
,
1784 Object_Definition
=> New_Occurrence_Of
(Stent
, Loc
),
1785 Constant_Present
=> True,
1786 Aliased_Present
=> True,
1788 Make_Aggregate
(Loc
,
1790 Make_Integer_Literal
(Loc
, List_Length
(SD_List
)),
1792 Make_Aggregate
(Loc
,
1793 Expressions
=> SD_List
))));
1795 Insert_Library_Level_Action
(Decl
);
1797 Set_Is_Exported
(Ent
, True);
1798 Set_Is_Public
(Ent
, True);
1799 Set_Is_Statically_Allocated
(Ent
, True);
1801 Get_Name_String
(Chars
(Ent
));
1802 Set_Interface_Name
(Ent
,
1803 Make_String_Literal
(Loc
,
1804 Strval
=> String_From_Name_Buffer
));
1806 end Generate_Unit_Exception_Table
;
1812 procedure Initialize
is
1814 SD_List
:= Empty_List
;
1817 ----------------------
1818 -- Is_Non_Ada_Error --
1819 ----------------------
1821 function Is_Non_Ada_Error
(E
: Entity_Id
) return Boolean is
1823 if not OpenVMS_On_Target
then
1827 Get_Name_String
(Chars
(E
));
1829 -- Note: it is a little irregular for the body of exp_ch11 to know
1830 -- the details of the encoding scheme for names, but on the other
1831 -- hand, gigi knows them, and this is for gigi's benefit anyway!
1833 if Name_Buffer
(1 .. 30) /= "system__aux_dec__non_ada_error" then
1838 end Is_Non_Ada_Error
;
1840 ----------------------------
1841 -- Remove_Handler_Entries --
1842 ----------------------------
1844 procedure Remove_Handler_Entries
(N
: Node_Id
) is
1845 function Check_Handler_Entry
(N
: Node_Id
) return Traverse_Result
;
1846 -- This function checks one node for a possible reference to a
1847 -- handler entry that must be deleted. it always returns OK.
1849 function Remove_All_Handler_Entries
is new
1850 Traverse_Func
(Check_Handler_Entry
);
1851 -- This defines the traversal operation
1853 Discard
: Traverse_Result
;
1855 function Check_Handler_Entry
(N
: Node_Id
) return Traverse_Result
is
1857 if Nkind
(N
) = N_Object_Declaration
then
1859 if Present
(Handler_List_Entry
(N
)) then
1860 Remove
(Handler_List_Entry
(N
));
1861 Delete_Tree
(Handler_List_Entry
(N
));
1862 Set_Handler_List_Entry
(N
, Empty
);
1864 elsif Is_Subprogram_Descriptor
(N
) then
1869 SDN
:= First
(SD_List
);
1870 while Present
(SDN
) loop
1871 if Defining_Identifier
(N
) = Entity
(Prefix
(SDN
)) then
1884 end Check_Handler_Entry
;
1886 -- Start of processing for Remove_Handler_Entries
1889 if Exception_Mechanism
= Front_End_ZCX
then
1890 Discard
:= Remove_All_Handler_Entries
(N
);
1892 end Remove_Handler_Entries
;