1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2003 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 -- This expansion is only done if we have front end exception handling.
111 -- If we have back end exception handling, then the AT END handler is
112 -- left alone, and cleanups (including the exceptional case) are handled
115 -- In the front end case, the exception handler described above handles
116 -- the exceptional case. The AT END handler is left in the generated tree
117 -- and the code generator (e.g. gigi) must still handle proper generation
118 -- of cleanup calls for the non-exceptional case.
120 procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id) is
121 Clean : constant Entity_Id := Entity (At_End_Proc (HSS));
122 Loc : constant Source_Ptr := Sloc (Clean);
127 pragma Assert (Present (Clean));
128 pragma Assert (No (Exception_Handlers (HSS)));
130 -- Don't expand if back end exception handling active
132 if Exception_Mechanism = Back_End_ZCX_Exceptions then
136 -- Don't expand an At End handler if we have already had configurable
137 -- run-time violations, since likely this will just be a matter of
138 -- generating useless cascaded messages
140 if Configurable_Run_Time_Violations > 0 then
144 if Restrictions (No_Exception_Handlers) then
148 if Present (Block) then
153 Make_Others_Choice (Loc);
154 Set_All_Others (Ohandle);
157 Make_Procedure_Call_Statement (Loc,
158 Name => New_Occurrence_Of (Clean, Loc)),
159 Make_Raise_Statement (Loc));
161 Set_Exception_Handlers (HSS, New_List (
162 Make_Exception_Handler (Loc,
163 Exception_Choices => New_List (Ohandle),
164 Statements => Stmnts)));
166 Analyze_List (Stmnts, Suppress => All_Checks);
167 Expand_Exception_Handlers (HSS);
169 if Present (Block) then
172 end Expand_At_End_Handler;
174 -------------------------------------
175 -- Expand_Exception_Handler_Tables --
176 -------------------------------------
178 -- See Ada.Exceptions specification for full details of the data
179 -- structures that we need to construct here. As an example of the
180 -- transformation that is required, given the structure:
197 -- We transform this into:
219 -- HR2 : constant Handler_Record := (
223 -- Handler => L5'Address);
225 -- HR3 : constant Handler_Record := (
229 -- Handler => L4'Address);
235 -- HR1 : constant Handler_Record := (
239 -- Handler => L4'Address);
242 -- The exception handlers in the transformed version are marked with the
243 -- Zero_Cost_Handling flag set, and all gigi does in this case is simply
244 -- to put the handler code somewhere. It can optionally be put inline
245 -- between the goto L3 and the label <<L3>> (which is why we generate
246 -- that goto in the first place).
248 procedure Expand_Exception_Handler_Tables (HSS : Node_Id) is
249 Loc : constant Source_Ptr := Sloc (HSS);
250 Handlrs : constant List_Id := Exception_Handlers (HSS);
251 Stms : constant List_Id := Statements (HSS);
255 -- This is the list to which handlers are to be appended. It is
256 -- either the list for the enclosing subprogram, or the enclosing
257 -- selective accept statement (which will turn into a subprogram
258 -- during expansion later on).
260 L1 : constant Entity_Id :=
261 Make_Defining_Identifier (Loc,
262 Chars => New_Internal_Name ('L'));
264 L2 : constant Entity_Id :=
265 Make_Defining_Identifier (Loc,
266 Chars => New_Internal_Name ('L'));
275 Subp_Entity : Entity_Id;
276 -- This is the entity for the subprogram (or library level package)
277 -- to which the handler record is to be attached for later reference
278 -- in a subprogram descriptor for this entity.
280 procedure Append_To_Stms (N : Node_Id);
281 -- Append given statement to the end of the statements of the
282 -- handled sequence of statements and analyze it in place.
284 function Inside_Selective_Accept return Boolean;
285 -- This function is called if we are inside the scope of an entry
286 -- or task. It checks if the handler is appearing in the context
287 -- of a selective accept statement. If so, Hlist is set to
288 -- temporarily park the handlers in the N_Accept_Alternative.
289 -- node. They will subsequently be moved to the procedure entity
290 -- for the procedure built for this alternative. The statements that
291 -- follow the Accept within the alternative are not inside the Accept
292 -- for purposes of this test, and handlers that may appear within
293 -- them belong in the enclosing task procedure.
296 -- Sets the handler list corresponding to Subp_Entity
302 procedure Append_To_Stms (N : Node_Id) is
304 Insert_After_And_Analyze (Last (Stms), N);
305 Set_Exception_Junk (N);
308 -----------------------------
309 -- Inside_Selective_Accept --
310 -----------------------------
312 function Inside_Selective_Accept return Boolean is
314 Curr : Node_Id := HSS;
317 Parnt := Parent (HSS);
318 while Nkind (Parnt) /= N_Compilation_Unit loop
319 if Nkind (Parnt) = N_Accept_Alternative
320 and then Curr = Accept_Statement (Parnt)
322 if Present (Accept_Handler_Records (Parnt)) then
323 Hlist := Accept_Handler_Records (Parnt);
326 Set_Accept_Handler_Records (Parnt, Hlist);
332 Parnt := Parent (Parnt);
337 end Inside_Selective_Accept;
343 procedure Set_Hlist is
345 -- Never try to inline a subprogram with exception handlers
347 Set_Is_Inlined (Subp_Entity, False);
349 if Present (Subp_Entity)
350 and then Present (Handler_Records (Subp_Entity))
352 Hlist := Handler_Records (Subp_Entity);
355 Set_Handler_Records (Subp_Entity, Hlist);
359 -- Start of processing for Expand_Exception_Handler_Tables
362 -- Nothing to do if this handler has already been processed
364 if Zero_Cost_Handling (HSS) then
368 Set_Zero_Cost_Handling (HSS);
370 -- Find the parent subprogram or package scope containing this
371 -- exception frame. This should always find a real package or
372 -- subprogram. If it does not it will stop at Standard, but
373 -- this cannot legitimately occur.
375 -- We only stop at library level packages, for inner packages
376 -- we always attach handlers to the containing procedure.
378 Subp_Entity := Current_Scope;
381 -- Never need tables expanded inside a generic template
383 if Is_Generic_Unit (Subp_Entity) then
386 -- Stop if we reached containing subprogram. Go to protected
387 -- subprogram if there is one defined.
389 elsif Ekind (Subp_Entity) = E_Function
390 or else Ekind (Subp_Entity) = E_Procedure
392 if Present (Protected_Body_Subprogram (Subp_Entity)) then
393 Subp_Entity := Protected_Body_Subprogram (Subp_Entity);
399 -- Case of within an entry
401 elsif Is_Entry (Subp_Entity) then
403 -- Protected entry, use corresponding body subprogram
405 if Present (Protected_Body_Subprogram (Subp_Entity)) then
406 Subp_Entity := Protected_Body_Subprogram (Subp_Entity);
410 -- Check if we are within a selective accept alternative
412 elsif Inside_Selective_Accept then
414 -- As a side effect, Inside_Selective_Accept set Hlist,
415 -- in much the same manner as Set_Hlist, except that
416 -- the list involved was the one for the selective accept.
421 -- Case of within library level package
423 elsif Ekind (Subp_Entity) = E_Package
424 and then Is_Compilation_Unit (Subp_Entity)
426 if Is_Body_Name (Unit_Name (Get_Code_Unit (HSS))) then
427 Subp_Entity := Body_Entity (Subp_Entity);
435 elsif Ekind (Subp_Entity) = E_Task_Type then
437 -- Check if we are within a selective accept alternative
439 if Inside_Selective_Accept then
441 -- As a side effect, Inside_Selective_Accept set Hlist,
442 -- in much the same manner as Set_Hlist, except that the
443 -- list involved was the one for the selective accept.
447 -- Stop if we reached task type with task body procedure,
448 -- use the task body procedure.
450 elsif Present (Get_Task_Body_Procedure (Subp_Entity)) then
451 Subp_Entity := Get_Task_Body_Procedure (Subp_Entity);
457 -- If we fall through, keep looking
459 Subp_Entity := Scope (Subp_Entity);
462 pragma Assert (Subp_Entity /= Standard_Standard);
464 -- Analyze standard labels
466 Analyze_Label_Entity (L1);
467 Analyze_Label_Entity (L2);
469 Insert_Before_And_Analyze (First (Stms),
471 Identifier => New_Occurrence_Of (L1, Loc)));
472 Set_Exception_Junk (First (Stms));
476 Identifier => New_Occurrence_Of (L2, Loc)));
478 -- Loop through exception handlers
480 Handler := First_Non_Pragma (Handlrs);
481 while Present (Handler) loop
482 Set_Zero_Cost_Handling (Handler);
484 -- Add label at start of handler, and goto at the end
487 Make_Defining_Identifier (Loc,
488 Chars => New_Internal_Name ('L'));
490 Analyze_Label_Entity (Lnn);
494 Identifier => New_Occurrence_Of (Lnn, Loc));
495 Set_Exception_Junk (Item);
496 Insert_Before_And_Analyze (First (Statements (Handler)), Item);
498 -- Loop through choices
500 Choice := First (Exception_Choices (Handler));
501 while Present (Choice) loop
503 -- Others (or all others) choice
505 if Nkind (Choice) = N_Others_Choice then
506 if All_Others (Choice) then
507 E_Id := New_Occurrence_Of (RTE (RE_All_Others_Id), Loc);
509 E_Id := New_Occurrence_Of (RTE (RE_Others_Id), Loc);
512 -- Special case of VMS_Exception. Not clear what we will do
513 -- eventually here if and when we implement zero cost exceptions
514 -- on VMS. But at least for now, don't blow up trying to take
515 -- a garbage code address for such an exception.
517 elsif Is_VMS_Exception (Entity (Choice)) then
518 E_Id := New_Occurrence_Of (RTE (RE_Null_Id), Loc);
520 -- Normal case of specific exception choice
524 Make_Attribute_Reference (Loc,
525 Prefix => New_Occurrence_Of (Entity (Choice), Loc),
526 Attribute_Name => Name_Identity);
530 Make_Defining_Identifier (Loc,
531 Chars => New_Internal_Name ('H'));
534 Make_Attribute_Reference (Loc,
535 Prefix => New_Occurrence_Of (HR_Ent, Loc),
536 Attribute_Name => Name_Unrestricted_Access);
538 -- Now we need to add the entry for the new handler record to
539 -- the list of handler records for the current subprogram.
541 -- Normally we end up generating the handler records in exactly
542 -- the right order. Here right order means innermost first,
543 -- since the table will be searched sequentially. Since we
544 -- generally expand from outside to inside, the order is just
545 -- what we want, and we need to append the new entry to the
548 -- However, there are exceptions, notably in the case where
549 -- a generic body is inserted later on. See for example the
550 -- case of ACVC test C37213J, which has the following form:
552 -- generic package x ... end x;
563 -- package q is new x;
570 -- In this case, we will expand exception handler (2) first,
571 -- since the expansion of (1) is delayed till later when the
572 -- generic body is inserted. But (1) belongs before (2) in
575 -- Note that scopes are not totally ordered, because two
576 -- scopes can be in parallel blocks, so that it does not
577 -- matter what order these entries appear in. An ordering
578 -- relation exists if one scope is inside another, and what
579 -- we really want is some partial ordering.
581 -- A simple, not very efficient, but adequate algorithm to
582 -- achieve this partial ordering is to search the list for
583 -- the first entry containing the given scope, and put the
584 -- new entry just before it.
587 New_Scop : constant Entity_Id := Current_Scope;
591 Ent := First (Hlist);
593 -- If all searched, then we can just put the new
594 -- entry at the end of the list (it actually does
595 -- not matter where we put it in this case).
598 Append_To (Hlist, HL_Ref);
601 -- If the current scope is within the scope of the
602 -- entry then insert the entry before to retain the
603 -- proper order as per above discussion.
605 -- Note that for equal entries, we just keep going,
606 -- which is fine, the entry will end up at the end
607 -- of the list where it belongs.
610 (New_Scop, Scope (Entity (Prefix (Ent))))
612 Insert_Before (Ent, HL_Ref);
615 -- Otherwise keep looking
624 Make_Object_Declaration (Loc,
625 Defining_Identifier => HR_Ent,
626 Constant_Present => True,
627 Aliased_Present => True,
629 New_Occurrence_Of (RTE (RE_Handler_Record), Loc),
633 Expressions => New_List (
634 Make_Attribute_Reference (Loc, -- Lo
635 Prefix => New_Occurrence_Of (L1, Loc),
636 Attribute_Name => Name_Address),
638 Make_Attribute_Reference (Loc, -- Hi
639 Prefix => New_Occurrence_Of (L2, Loc),
640 Attribute_Name => Name_Address),
644 Make_Attribute_Reference (Loc,
645 Prefix => New_Occurrence_Of (Lnn, Loc), -- Handler
646 Attribute_Name => Name_Address))));
648 Set_Handler_List_Entry (Item, HL_Ref);
649 Set_Exception_Junk (Item);
650 Insert_After_And_Analyze (Last (Statements (Handler)), Item);
651 Set_Is_Statically_Allocated (HR_Ent);
653 -- If this is a late insertion (from body instance) it is being
654 -- inserted in the component list of an already analyzed aggre-
655 -- gate, and must be analyzed explicitly.
657 Analyze_And_Resolve (HL_Ref, RTE (RE_Handler_Record_Ptr));
662 Next_Non_Pragma (Handler);
664 end Expand_Exception_Handler_Tables;
666 -------------------------------
667 -- Expand_Exception_Handlers --
668 -------------------------------
670 procedure Expand_Exception_Handlers (HSS : Node_Id) is
671 Handlrs : constant List_Id := Exception_Handlers (HSS);
674 Others_Choice : Boolean;
677 procedure Prepend_Call_To_Handler
679 Args : List_Id := No_List);
680 -- Routine to prepend a call to the procedure referenced by Proc at
681 -- the start of the handler code for the current Handler.
683 -----------------------------
684 -- Prepend_Call_To_Handler --
685 -----------------------------
687 procedure Prepend_Call_To_Handler
689 Args : List_Id := No_List)
691 Ent : constant Entity_Id := RTE (Proc);
694 -- If we have no Entity, then we are probably in no run time mode
695 -- or some weird error has occured. In either case do do nothing!
697 if Present (Ent) then
699 Call : constant Node_Id :=
700 Make_Procedure_Call_Statement (Loc,
701 Name => New_Occurrence_Of (RTE (Proc), Loc),
702 Parameter_Associations => Args);
705 Prepend_To (Statements (Handler), Call);
706 Analyze (Call, Suppress => All_Checks);
709 end Prepend_Call_To_Handler;
711 -- Start of processing for Expand_Exception_Handlers
714 -- Loop through handlers
716 Handler := First_Non_Pragma (Handlrs);
717 Handler_Loop : while Present (Handler) loop
718 Loc := Sloc (Handler);
720 -- Remove source handler if gnat debug flag N is set
722 if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
724 H : constant Node_Id := Handler;
726 Next_Non_Pragma (Handler);
728 goto Continue_Handler_Loop;
733 -- If an exception occurrence is present, then we must declare it
734 -- and initialize it from the value stored in the TSD
737 -- name : Exception_Occurrence;
740 -- Save_Occurrence (name, Get_Current_Excep.all)
744 if Present (Choice_Parameter (Handler)) then
746 Cparm : constant Entity_Id := Choice_Parameter (Handler);
747 Clc : constant Source_Ptr := Sloc (Cparm);
752 Make_Procedure_Call_Statement (Loc,
754 New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc),
755 Parameter_Associations => New_List (
756 New_Occurrence_Of (Cparm, Clc),
757 Make_Explicit_Dereference (Loc,
758 Make_Function_Call (Loc,
759 Name => Make_Explicit_Dereference (Loc,
761 (RTE (RE_Get_Current_Excep), Loc))))));
763 Mark_Rewrite_Insertion (Save);
764 Prepend (Save, Statements (Handler));
767 Make_Object_Declaration (Clc,
768 Defining_Identifier => Cparm,
771 (RTE (RE_Exception_Occurrence), Clc));
772 Set_No_Initialization (Obj_Decl, True);
775 Make_Exception_Handler (Loc,
776 Exception_Choices => Exception_Choices (Handler),
778 Statements => New_List (
779 Make_Block_Statement (Loc,
780 Declarations => New_List (Obj_Decl),
781 Handled_Statement_Sequence =>
782 Make_Handled_Sequence_Of_Statements (Loc,
783 Statements => Statements (Handler))))));
785 Analyze_List (Statements (Handler), Suppress => All_Checks);
789 -- The processing at this point is rather different for the
790 -- JVM case, so we completely separate the processing.
792 -- For the JVM case, we unconditionally call Update_Exception,
793 -- passing a call to the intrinsic function Current_Target_Exception
794 -- (see JVM version of Ada.Exceptions in 4jexcept.adb for details).
796 if Hostparm.Java_VM then
798 Arg : constant Node_Id :=
799 Make_Function_Call (Loc,
800 Name => New_Occurrence_Of
801 (RTE (RE_Current_Target_Exception), Loc));
803 Prepend_Call_To_Handler (RE_Update_Exception, New_List (Arg));
806 -- For the normal case, we have to worry about the state of abort
807 -- deferral. Generally, we defer abort during runtime handling of
808 -- exceptions. When control is passed to the handler, then in the
809 -- normal case we undefer aborts. In any case this entire handling
810 -- is relevant only if aborts are allowed!
812 elsif Abort_Allowed then
814 -- There are some special cases in which we do not do the
815 -- undefer. In particular a finalization (AT END) handler
816 -- wants to operate with aborts still deferred.
818 -- We also suppress the call if this is the special handler
819 -- for Abort_Signal, since if we are aborting, we want to keep
820 -- aborts deferred (one abort is enough thank you very much :-)
822 -- If abort really needs to be deferred the expander must add
823 -- this call explicitly, see Exp_Ch9.Expand_N_Asynchronous_Select.
826 Nkind (First (Exception_Choices (Handler))) = N_Others_Choice;
829 or else Entity (First (Exception_Choices (Handler))) /=
833 and then All_Others (First (Exception_Choices (Handler))))
834 and then Abort_Allowed
836 Prepend_Call_To_Handler (RE_Abort_Undefer);
840 Next_Non_Pragma (Handler);
842 <<Continue_Handler_Loop>>
844 end loop Handler_Loop;
846 -- If all handlers got removed by gnatdN, then remove the list
849 and then Is_Empty_List (Exception_Handlers (HSS))
851 Set_Exception_Handlers (HSS, No_List);
854 -- The last step for expanding exception handlers is to expand the
855 -- exception tables if zero cost exception handling is active.
857 if Exception_Mechanism = Front_End_ZCX_Exceptions then
858 Expand_Exception_Handler_Tables (HSS);
860 end Expand_Exception_Handlers;
862 ------------------------------------
863 -- Expand_N_Exception_Declaration --
864 ------------------------------------
867 -- exceptE : constant String := "A.B.EXCEP"; -- static data
868 -- except : exception_data := (
869 -- Handled_By_Other => False,
871 -- Name_Length => exceptE'Length,
872 -- Full_Name => exceptE'Address,
873 -- HTable_Ptr => null,
875 -- Raise_Hook => null,
878 -- (protecting test only needed if not at library level)
880 -- exceptF : Boolean := True -- static data
883 -- Register_Exception (except'Unchecked_Access);
886 procedure Expand_N_Exception_Declaration (N : Node_Id) is
887 Loc : constant Source_Ptr := Sloc (N);
888 Id : constant Entity_Id := Defining_Identifier (N);
889 L : List_Id := New_List;
892 Name_Exname : constant Name_Id := New_External_Name (Chars (Id), 'E');
893 Exname : constant Node_Id :=
894 Make_Defining_Identifier (Loc, Name_Exname);
897 -- There is no expansion needed when compiling for the JVM since the
898 -- JVM has a built-in exception mechanism. See 4jexcept.ads for details.
900 if Hostparm.Java_VM then
904 -- Definition of the external name: nam : constant String := "A.B.NAME";
907 Make_Object_Declaration (Loc,
908 Defining_Identifier => Exname,
909 Constant_Present => True,
910 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
911 Expression => Make_String_Literal (Loc, Full_Qualified_Name (Id))));
913 Set_Is_Statically_Allocated (Exname);
915 -- Create the aggregate list for type Standard.Exception_Type:
916 -- Handled_By_Other component: False
918 Append_To (L, New_Occurrence_Of (Standard_False, Loc));
920 -- Lang component: 'A'
923 Make_Character_Literal (Loc, Name_uA, Get_Char_Code ('A')));
925 -- Name_Length component: Nam'Length
928 Make_Attribute_Reference (Loc,
929 Prefix => New_Occurrence_Of (Exname, Loc),
930 Attribute_Name => Name_Length));
932 -- Full_Name component: Standard.A_Char!(Nam'Address)
934 Append_To (L, Unchecked_Convert_To (Standard_A_Char,
935 Make_Attribute_Reference (Loc,
936 Prefix => New_Occurrence_Of (Exname, Loc),
937 Attribute_Name => Name_Address)));
939 -- HTable_Ptr component: null
941 Append_To (L, Make_Null (Loc));
943 -- Import_Code component: 0
945 Append_To (L, Make_Integer_Literal (Loc, 0));
947 -- Raise_Hook component: null
949 Append_To (L, Make_Null (Loc));
951 Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
952 Analyze_And_Resolve (Expression (N), Etype (Id));
954 -- Register_Exception (except'Unchecked_Access);
956 if not Restrictions (No_Exception_Handlers)
957 and then not Restrictions (No_Exception_Registration)
960 Make_Procedure_Call_Statement (Loc,
961 Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc),
962 Parameter_Associations => New_List (
963 Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
964 Make_Attribute_Reference (Loc,
965 Prefix => New_Occurrence_Of (Id, Loc),
966 Attribute_Name => Name_Unrestricted_Access)))));
968 Set_Register_Exception_Call (Id, First (L));
970 if not Is_Library_Level_Entity (Id) then
971 Flag_Id := Make_Defining_Identifier (Loc,
972 New_External_Name (Chars (Id), 'F'));
975 Make_Object_Declaration (Loc,
976 Defining_Identifier => Flag_Id,
978 New_Occurrence_Of (Standard_Boolean, Loc),
980 New_Occurrence_Of (Standard_True, Loc)));
982 Set_Is_Statically_Allocated (Flag_Id);
985 Make_Assignment_Statement (Loc,
986 Name => New_Occurrence_Of (Flag_Id, Loc),
987 Expression => New_Occurrence_Of (Standard_False, Loc)));
989 Insert_After_And_Analyze (N,
990 Make_Implicit_If_Statement (N,
991 Condition => New_Occurrence_Of (Flag_Id, Loc),
992 Then_Statements => L));
995 Insert_List_After_And_Analyze (N, L);
999 end Expand_N_Exception_Declaration;
1001 ---------------------------------------------
1002 -- Expand_N_Handled_Sequence_Of_Statements --
1003 ---------------------------------------------
1005 procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is
1007 if Present (Exception_Handlers (N))
1008 and then not Restrictions (No_Exception_Handlers)
1010 Expand_Exception_Handlers (N);
1013 -- The following code needs comments ???
1015 if Nkind (Parent (N)) /= N_Package_Body
1016 and then Nkind (Parent (N)) /= N_Accept_Statement
1017 and then not Delay_Cleanups (Current_Scope)
1019 Expand_Cleanup_Actions (Parent (N));
1021 Set_First_Real_Statement (N, First (Statements (N)));
1024 end Expand_N_Handled_Sequence_Of_Statements;
1026 -------------------------------------
1027 -- Expand_N_Raise_Constraint_Error --
1028 -------------------------------------
1030 -- The only processing required is to adjust the condition to deal
1031 -- with the C/Fortran boolean case. This may well not be necessary,
1032 -- as all such conditions are generated by the expander and probably
1033 -- are all standard boolean, but who knows what strange optimization
1034 -- in future may require this adjustment!
1036 procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is
1038 Adjust_Condition (Condition (N));
1039 end Expand_N_Raise_Constraint_Error;
1041 ----------------------------------
1042 -- Expand_N_Raise_Program_Error --
1043 ----------------------------------
1045 -- The only processing required is to adjust the condition to deal
1046 -- with the C/Fortran boolean case. This may well not be necessary,
1047 -- as all such conditions are generated by the expander and probably
1048 -- are all standard boolean, but who knows what strange optimization
1049 -- in future may require this adjustment!
1051 procedure Expand_N_Raise_Program_Error (N : Node_Id) is
1053 Adjust_Condition (Condition (N));
1054 end Expand_N_Raise_Program_Error;
1056 ------------------------------
1057 -- Expand_N_Raise_Statement --
1058 ------------------------------
1060 procedure Expand_N_Raise_Statement (N : Node_Id) is
1061 Loc : constant Source_Ptr := Sloc (N);
1067 -- There is no expansion needed for statement "raise <exception>;" when
1068 -- compiling for the JVM since the JVM has a built-in exception
1069 -- mechanism. However we need the keep the expansion for "raise;"
1070 -- statements. See 4jexcept.ads for details.
1072 if Present (Name (N)) and then Hostparm.Java_VM then
1076 -- Don't expand a raise statement that does not come from source
1077 -- if we have already had configurable run-time violations, since
1078 -- most likely it will be junk cascaded nonsense.
1080 if Configurable_Run_Time_Violations > 0
1081 and then not Comes_From_Source (N)
1086 -- Convert explicit raise of Program_Error, Constraint_Error, and
1087 -- Storage_Error into the corresponding raise (in High_Integrity_Mode
1088 -- all other raises will get normal expansion and be disallowed,
1089 -- but this is also faster in all modes).
1091 if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
1092 if Entity (Name (N)) = Standard_Constraint_Error then
1094 Make_Raise_Constraint_Error (Loc,
1095 Reason => CE_Explicit_Raise));
1099 elsif Entity (Name (N)) = Standard_Program_Error then
1101 Make_Raise_Program_Error (Loc,
1102 Reason => PE_Explicit_Raise));
1106 elsif Entity (Name (N)) = Standard_Storage_Error then
1108 Make_Raise_Storage_Error (Loc,
1109 Reason => SE_Explicit_Raise));
1115 -- Case of name present, in this case we expand raise name to
1117 -- Raise_Exception (name'Identity, location_string);
1119 -- where location_string identifies the file/line of the raise
1121 if Present (Name (N)) then
1123 Id : Entity_Id := Entity (Name (N));
1126 Build_Location_String (Loc);
1128 -- If the exception is a renaming, use the exception that it
1129 -- renames (which might be a predefined exception, e.g.).
1131 if Present (Renamed_Object (Id)) then
1132 Id := Renamed_Object (Id);
1135 -- Build a C-compatible string in case of no exception handlers,
1136 -- since this is what the last chance handler is expecting.
1138 if Restrictions (No_Exception_Handlers) then
1140 -- Generate an empty message if configuration pragma
1141 -- Suppress_Exception_Locations is set for this unit.
1143 if Opt.Exception_Locations_Suppressed then
1146 Name_Len := Name_Len + 1;
1149 Name_Buffer (Name_Len) := ASCII.NUL;
1153 if Opt.Exception_Locations_Suppressed then
1157 Str := String_From_Name_Buffer;
1159 -- For VMS exceptions, convert the raise into a call to
1160 -- lib$stop so it will be handled by __gnat_error_handler.
1162 if Is_VMS_Exception (Id) then
1164 Excep_Image : String_Id;
1168 if Present (Interface_Name (Id)) then
1169 Excep_Image := Strval (Interface_Name (Id));
1171 Get_Name_String (Chars (Id));
1173 Excep_Image := String_From_Name_Buffer;
1176 if Exception_Code (Id) /= No_Uint then
1178 Make_Integer_Literal (Loc, Exception_Code (Id));
1181 Unchecked_Convert_To (Standard_Integer,
1182 Make_Function_Call (Loc,
1183 Name => New_Occurrence_Of
1184 (RTE (RE_Import_Value), Loc),
1185 Parameter_Associations => New_List
1186 (Make_String_Literal (Loc,
1187 Strval => Excep_Image))));
1191 Make_Procedure_Call_Statement (Loc,
1193 New_Occurrence_Of (RTE (RE_Lib_Stop), Loc),
1194 Parameter_Associations => New_List (Cond)));
1195 Analyze_And_Resolve (Cond, Standard_Integer);
1198 -- Not VMS exception case, convert raise to call to the
1199 -- Raise_Exception routine.
1203 Make_Procedure_Call_Statement (Loc,
1204 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1205 Parameter_Associations => New_List (
1206 Make_Attribute_Reference (Loc,
1208 Attribute_Name => Name_Identity),
1209 Make_String_Literal (Loc,
1214 -- Case of no name present (reraise). We rewrite the raise to:
1216 -- Reraise_Occurrence_Always (EO);
1218 -- where EO is the current exception occurrence. If the current handler
1219 -- does not have a choice parameter specification, then we provide one.
1222 -- Find innermost enclosing exception handler (there must be one,
1223 -- since the semantics has already verified that this raise statement
1224 -- is valid, and a raise with no arguments is only permitted in the
1225 -- context of an exception handler.
1227 Ehand := Parent (N);
1228 while Nkind (Ehand) /= N_Exception_Handler loop
1229 Ehand := Parent (Ehand);
1232 -- Make exception choice parameter if none present. Note that we do
1233 -- not need to put the entity on the entity chain, since no one will
1234 -- be referencing this entity by normal visibility methods.
1236 if No (Choice_Parameter (Ehand)) then
1237 E := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
1238 Set_Choice_Parameter (Ehand, E);
1239 Set_Ekind (E, E_Variable);
1240 Set_Etype (E, RTE (RE_Exception_Occurrence));
1241 Set_Scope (E, Current_Scope);
1244 -- Now rewrite the raise as a call to Reraise. A special case arises
1245 -- if this raise statement occurs in the context of a handler for
1246 -- all others (i.e. an at end handler). in this case we avoid
1247 -- the call to defer abort, cleanup routines are expected to be
1248 -- called in this case with aborts deferred.
1251 Ech : constant Node_Id := First (Exception_Choices (Ehand));
1255 if Nkind (Ech) = N_Others_Choice
1256 and then All_Others (Ech)
1258 Ent := RTE (RE_Reraise_Occurrence_No_Defer);
1260 Ent := RTE (RE_Reraise_Occurrence_Always);
1264 Make_Procedure_Call_Statement (Loc,
1265 Name => New_Occurrence_Of (Ent, Loc),
1266 Parameter_Associations => New_List (
1267 New_Occurrence_Of (Choice_Parameter (Ehand), Loc))));
1272 end Expand_N_Raise_Statement;
1274 ----------------------------------
1275 -- Expand_N_Raise_Storage_Error --
1276 ----------------------------------
1278 -- The only processing required is to adjust the condition to deal
1279 -- with the C/Fortran boolean case. This may well not be necessary,
1280 -- as all such conditions are generated by the expander and probably
1281 -- are all standard boolean, but who knows what strange optimization
1282 -- in future may require this adjustment!
1284 procedure Expand_N_Raise_Storage_Error (N : Node_Id) is
1286 Adjust_Condition (Condition (N));
1287 end Expand_N_Raise_Storage_Error;
1289 ------------------------------
1290 -- Expand_N_Subprogram_Info --
1291 ------------------------------
1293 procedure Expand_N_Subprogram_Info (N : Node_Id) is
1294 Loc : constant Source_Ptr := Sloc (N);
1297 -- For now, we replace an Expand_N_Subprogram_Info node with an
1298 -- attribute reference that gives the address of the procedure.
1299 -- This is because gigi does not yet recognize this node, and
1300 -- for the initial targets, this is the right value anyway.
1303 Make_Attribute_Reference (Loc,
1304 Prefix => Identifier (N),
1305 Attribute_Name => Name_Code_Address));
1307 Analyze_And_Resolve (N, RTE (RE_Code_Loc));
1308 end Expand_N_Subprogram_Info;
1310 ------------------------------------
1311 -- Generate_Subprogram_Descriptor --
1312 ------------------------------------
1314 procedure Generate_Subprogram_Descriptor
1329 if Exception_Mechanism /= Front_End_ZCX_Exceptions then
1333 if Restrictions (No_Exception_Handlers) then
1337 -- Suppress descriptor if we are not generating code. This happens
1338 -- in the case of a -gnatc -gnatt compilation where we force generics
1339 -- to be generated, but we still don't want exception tables.
1341 if Operating_Mode /= Generate_Code then
1345 -- Suppress descriptor if we are in No_Exceptions restrictions mode,
1346 -- since we can never propagate exceptions in any case in this mode.
1347 -- The same consideration applies for No_Exception_Handlers (which
1348 -- is also set in High_Integrity_Mode).
1350 if Restrictions (No_Exceptions)
1351 or Restrictions (No_Exception_Handlers)
1356 -- Suppress descriptor if we are inside a generic. There are two
1357 -- ways that we can tell that, depending on what is going on. If
1358 -- we are actually inside the processing for a generic right now,
1359 -- then Expander_Active will be reset. If we are outside the
1360 -- generic, then we will see the generic entity.
1362 if not Expander_Active then
1366 -- Suppress descriptor is subprogram is marked as eliminated, for
1367 -- example if this is a subprogram created to analyze a default
1368 -- expression with potential side effects. Ditto if it is nested
1369 -- within an eliminated subprogram, for example a cleanup action.
1376 while Scop /= Standard_Standard loop
1377 if Is_Generic_Unit (Scop) or else Is_Eliminated (Scop) then
1381 Scop := Scope (Scop);
1385 -- Suppress descriptor for original protected subprogram (we will
1386 -- be called again later to generate the descriptor for the actual
1387 -- protected body subprogram.) This does not apply to barrier
1388 -- functions which are there own protected subprogram.
1390 if Is_Subprogram (Spec)
1391 and then Present (Protected_Body_Subprogram (Spec))
1392 and then Protected_Body_Subprogram (Spec) /= Spec
1397 -- Suppress descriptors for packages unless they have at least one
1398 -- handler. The binder will generate the dummy (no handler) descriptors
1399 -- for elaboration procedures. We can't do it here, because we don't
1400 -- know if an elaboration routine does in fact exist.
1402 -- If there is at least one handler for the package spec or body
1403 -- then most certainly an elaboration routine must exist, so we
1404 -- can safely reference it.
1406 if (Nkind (N) = N_Package_Declaration
1408 Nkind (N) = N_Package_Body)
1409 and then No (Handler_Records (Spec))
1414 -- Suppress all subprogram descriptors for the file System.Exceptions.
1415 -- We similarly suppress subprogram descriptors for Ada.Exceptions.
1416 -- These are all init procs for types which cannot raise exceptions.
1417 -- The reason this is done is that otherwise we get embarassing
1418 -- elaboration dependencies.
1420 Get_Name_String (Unit_File_Name (Current_Sem_Unit));
1422 if Name_Buffer (1 .. 12) = "s-except.ads"
1424 Name_Buffer (1 .. 12) = "a-except.ads"
1429 -- Similarly, we need to suppress entries for System.Standard_Library,
1430 -- since otherwise we get elaboration circularities. Again, this would
1431 -- better be done with a Suppress_Initialization pragma :-)
1433 if Name_Buffer (1 .. 11) = "s-stalib.ad" then
1437 -- For now, also suppress entries for s-stoele because we have
1438 -- some kind of unexplained error there ???
1440 if Name_Buffer (1 .. 11) = "s-stoele.ad" then
1444 -- And also for g-htable, because it cannot raise exceptions,
1445 -- and generates some kind of elaboration order problem.
1447 if Name_Buffer (1 .. 11) = "g-htable.ad" then
1451 -- Suppress subprogram descriptor if already generated. This happens
1452 -- in the case of late generation from Delay_Subprogram_Descriptors
1453 -- beging set (where there is more than one instantiation in the list)
1455 if Has_Subprogram_Descriptor (Spec) then
1458 Set_Has_Subprogram_Descriptor (Spec);
1461 -- Never generate descriptors for inlined bodies
1463 if Analyzing_Inlined_Bodies then
1467 -- Here we definitely are going to generate a subprogram descriptor
1470 Hnum : Nat := Homonym_Number (Spec);
1478 Make_Defining_Identifier (Loc,
1479 Chars => New_External_Name (Chars (Spec), "SD", Hnum));
1482 if No (Handler_Records (Spec)) then
1486 Hrc := Handler_Records (Spec);
1487 Numh := List_Length (Hrc);
1492 -- We need a static subtype for the declaration of the subprogram
1493 -- descriptor. For the case of 0-3 handlers we can use one of the
1494 -- predefined subtypes in System.Exceptions. For more handlers,
1495 -- we build our own subtype here.
1499 Dtyp := RTE (RE_Subprogram_Descriptor_0);
1502 Dtyp := RTE (RE_Subprogram_Descriptor_1);
1505 Dtyp := RTE (RE_Subprogram_Descriptor_2);
1508 Dtyp := RTE (RE_Subprogram_Descriptor_3);
1512 Make_Defining_Identifier (Loc,
1513 Chars => New_Internal_Name ('T'));
1515 -- Set the constructed type as global, since we will be
1516 -- referencing the object that is of this type globally
1518 Set_Is_Statically_Allocated (Dtyp);
1521 Make_Subtype_Declaration (Loc,
1522 Defining_Identifier => Dtyp,
1523 Subtype_Indication =>
1524 Make_Subtype_Indication (Loc,
1526 New_Occurrence_Of (RTE (RE_Subprogram_Descriptor), Loc),
1528 Make_Index_Or_Discriminant_Constraint (Loc,
1529 Constraints => New_List (
1530 Make_Integer_Literal (Loc, Numh)))));
1532 Append (Decl, Slist);
1534 -- We analyze the descriptor for the subprogram and package
1535 -- case, but not for the imported subprogram case (it will
1536 -- be analyzed when the freeze entity actions are analyzed.
1542 Set_Exception_Junk (Decl);
1545 -- Prepare the code address entry for the table entry. For the normal
1546 -- case of being within a procedure, this is simply:
1550 -- where P is the procedure, but for the package case, it is
1552 -- P'Elab_Body'Code_Address
1553 -- P'Elab_Spec'Code_Address
1555 -- for the body and spec respectively. Note that we do our own
1556 -- analysis of these attribute references, because we know in this
1557 -- case that the prefix of ELab_Body/Spec is a visible package,
1558 -- which can be referenced directly instead of using the general
1559 -- case expansion for these attributes.
1561 if Ekind (Spec) = E_Package then
1563 Make_Attribute_Reference (Loc,
1564 Prefix => New_Occurrence_Of (Spec, Loc),
1565 Attribute_Name => Name_Elab_Spec);
1566 Set_Etype (Code, Standard_Void_Type);
1567 Set_Analyzed (Code);
1569 elsif Ekind (Spec) = E_Package_Body then
1571 Make_Attribute_Reference (Loc,
1572 Prefix => New_Occurrence_Of (Spec_Entity (Spec), Loc),
1573 Attribute_Name => Name_Elab_Body);
1574 Set_Etype (Code, Standard_Void_Type);
1575 Set_Analyzed (Code);
1578 Code := New_Occurrence_Of (Spec, Loc);
1582 Make_Attribute_Reference (Loc,
1584 Attribute_Name => Name_Code_Address);
1586 Set_Etype (Code, RTE (RE_Address));
1587 Set_Analyzed (Code);
1589 -- Now we can build the subprogram descriptor
1592 Make_Object_Declaration (Loc,
1593 Defining_Identifier => Ent,
1594 Constant_Present => True,
1595 Aliased_Present => True,
1596 Object_Definition => New_Occurrence_Of (Dtyp, Loc),
1599 Make_Aggregate (Loc,
1600 Expressions => New_List (
1601 Make_Integer_Literal (Loc, Numh), -- Num_Handlers
1607 -- Make_Subprogram_Info (Loc, -- Subprogram_Info
1609 -- New_Occurrence_Of (Spec, Loc)),
1611 New_Copy_Tree (Code),
1613 Make_Aggregate (Loc, -- Handler_Records
1614 Expressions => Hrc))));
1616 Set_Exception_Junk (Sdes);
1617 Set_Is_Subprogram_Descriptor (Sdes);
1619 Append (Sdes, Slist);
1621 -- We analyze the descriptor for the subprogram and package case,
1622 -- but not for the imported subprogram case (it will be analyzed
1623 -- when the freeze entity actions are analyzed.
1629 -- We can now pop the scope used for analyzing the descriptor
1633 -- We need to set the descriptor as statically allocated, since
1634 -- it will be referenced from the unit exception table.
1636 Set_Is_Statically_Allocated (Ent);
1638 -- Append the resulting descriptor to the list. We do this only
1639 -- if we are in the main unit. You might think that we could
1640 -- simply skip generating the descriptors completely if we are
1641 -- not in the main unit, but in fact this is not the case, since
1642 -- we have problems with inconsistent serial numbers for internal
1643 -- names if we do this.
1645 if In_Extended_Main_Code_Unit (Spec) then
1647 Make_Attribute_Reference (Loc,
1648 Prefix => New_Occurrence_Of (Ent, Loc),
1649 Attribute_Name => Name_Unrestricted_Access));
1651 Unit_Exception_Table_Present := True;
1654 end Generate_Subprogram_Descriptor;
1656 ------------------------------------------------------------
1657 -- Generate_Subprogram_Descriptor_For_Imported_Subprogram --
1658 ------------------------------------------------------------
1660 procedure Generate_Subprogram_Descriptor_For_Imported_Subprogram
1665 Generate_Subprogram_Descriptor (Empty, Sloc (Spec), Spec, Slist);
1666 end Generate_Subprogram_Descriptor_For_Imported_Subprogram;
1668 ------------------------------------------------
1669 -- Generate_Subprogram_Descriptor_For_Package --
1670 ------------------------------------------------
1672 procedure Generate_Subprogram_Descriptor_For_Package
1679 -- If N is empty with prior errors, ignore
1681 if Total_Errors_Detected /= 0 and then No (N) then
1685 -- Do not generate if no exceptions
1687 if Restrictions (No_Exception_Handlers) then
1691 -- Otherwise generate descriptor
1693 Adecl := Aux_Decls_Node (Parent (N));
1695 if No (Actions (Adecl)) then
1696 Set_Actions (Adecl, New_List);
1699 Generate_Subprogram_Descriptor (N, Sloc (N), Spec, Actions (Adecl));
1700 end Generate_Subprogram_Descriptor_For_Package;
1702 ---------------------------------------------------
1703 -- Generate_Subprogram_Descriptor_For_Subprogram --
1704 ---------------------------------------------------
1706 procedure Generate_Subprogram_Descriptor_For_Subprogram
1711 -- If we have no subprogram body and prior errors, ignore
1713 if Total_Errors_Detected /= 0 and then No (N) then
1717 -- Do not generate if no exceptions
1719 if Restrictions (No_Exception_Handlers) then
1723 -- Else generate descriptor
1726 HSS : constant Node_Id := Handled_Statement_Sequence (N);
1729 if No (Exception_Handlers (HSS)) then
1730 Generate_Subprogram_Descriptor
1731 (N, Sloc (N), Spec, Statements (HSS));
1733 Generate_Subprogram_Descriptor
1735 Spec, Statements (Last (Exception_Handlers (HSS))));
1738 end Generate_Subprogram_Descriptor_For_Subprogram;
1740 -----------------------------------
1741 -- Generate_Unit_Exception_Table --
1742 -----------------------------------
1744 -- The only remaining thing to generate here is to generate the
1745 -- reference to the subprogram descriptor chain. See Ada.Exceptions
1746 -- for details of required data structures.
1748 procedure Generate_Unit_Exception_Table is
1749 Loc : constant Source_Ptr := No_Location;
1753 Next_Ent : Entity_Id;
1757 -- Nothing to be done if zero length exceptions not active
1759 if Exception_Mechanism /= Front_End_ZCX_Exceptions then
1763 -- Nothing to do if no exceptions
1765 if Restrictions (No_Exception_Handlers) then
1769 -- Remove any entries from SD_List that correspond to eliminated
1772 Ent := First (SD_List);
1773 while Present (Ent) loop
1774 Next_Ent := Next (Ent);
1775 if Is_Eliminated (Scope (Entity (Prefix (Ent)))) then
1776 Remove (Ent); -- After this, there is no Next (Ent) anymore
1782 -- Nothing to do if no unit exception table present.
1783 -- An empty table can result from subprogram elimination,
1784 -- in such a case, eliminate the exception table itself.
1786 if Is_Empty_List (SD_List) then
1787 Unit_Exception_Table_Present := False;
1791 -- Do not generate table in a generic
1793 if Inside_A_Generic then
1797 -- Generate the unit exception table
1799 -- subtype Tnn is Subprogram_Descriptors_Record (Num);
1800 -- __gnat_unitname__SDP : aliased constant Tnn :=
1802 -- (sub1'unrestricted_access,
1803 -- sub2'unrestricted_access,
1805 -- subNum'unrestricted_access));
1807 Num := List_Length (SD_List);
1810 Make_Defining_Identifier (Loc,
1811 Chars => New_Internal_Name ('T'));
1813 Insert_Library_Level_Action (
1814 Make_Subtype_Declaration (Loc,
1815 Defining_Identifier => Stent,
1816 Subtype_Indication =>
1817 Make_Subtype_Indication (Loc,
1820 (RTE (RE_Subprogram_Descriptors_Record), Loc),
1822 Make_Index_Or_Discriminant_Constraint (Loc,
1823 Constraints => New_List (
1824 Make_Integer_Literal (Loc, Num))))));
1826 Set_Is_Statically_Allocated (Stent);
1828 Get_External_Unit_Name_String (Unit_Name (Main_Unit));
1829 Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
1830 Name_Buffer (1 .. 7) := "__gnat_";
1831 Name_Len := Name_Len + 7;
1832 Add_Str_To_Name_Buffer ("__SDP");
1835 Make_Defining_Identifier (Loc,
1836 Chars => Name_Find);
1838 Get_Name_String (Chars (Ent));
1839 Set_Interface_Name (Ent,
1840 Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
1843 Make_Object_Declaration (Loc,
1844 Defining_Identifier => Ent,
1845 Object_Definition => New_Occurrence_Of (Stent, Loc),
1846 Constant_Present => True,
1847 Aliased_Present => True,
1849 Make_Aggregate (Loc,
1851 Make_Integer_Literal (Loc, List_Length (SD_List)),
1853 Make_Aggregate (Loc,
1854 Expressions => SD_List))));
1856 Insert_Library_Level_Action (Decl);
1858 Set_Is_Exported (Ent, True);
1859 Set_Is_Public (Ent, True);
1860 Set_Is_Statically_Allocated (Ent, True);
1862 Get_Name_String (Chars (Ent));
1863 Set_Interface_Name (Ent,
1864 Make_String_Literal (Loc,
1865 Strval => String_From_Name_Buffer));
1867 end Generate_Unit_Exception_Table;
1873 procedure Initialize is
1875 SD_List := Empty_List;
1878 ----------------------
1879 -- Is_Non_Ada_Error --
1880 ----------------------
1882 function Is_Non_Ada_Error (E : Entity_Id) return Boolean is
1884 if not OpenVMS_On_Target then
1888 Get_Name_String (Chars (E));
1890 -- Note: it is a little irregular for the body of exp_ch11 to know
1891 -- the details of the encoding scheme for names, but on the other
1892 -- hand, gigi knows them, and this is for gigi's benefit anyway!
1894 if Name_Buffer (1 .. 30) /= "system__aux_dec__non_ada_error" then
1899 end Is_Non_Ada_Error;
1901 ----------------------------
1902 -- Remove_Handler_Entries --
1903 ----------------------------
1905 procedure Remove_Handler_Entries (N : Node_Id) is
1906 function Check_Handler_Entry (N : Node_Id) return Traverse_Result;
1907 -- This function checks one node for a possible reference to a
1908 -- handler entry that must be deleted. it always returns OK.
1910 function Remove_All_Handler_Entries is new
1911 Traverse_Func (Check_Handler_Entry);
1912 -- This defines the traversal operation
1914 Discard : Traverse_Result;
1915 pragma Warnings (Off, Discard);
1917 function Check_Handler_Entry (N : Node_Id) return Traverse_Result is
1919 if Nkind (N) = N_Object_Declaration then
1921 if Present (Handler_List_Entry (N)) then
1922 Remove (Handler_List_Entry (N));
1923 Delete_Tree (Handler_List_Entry (N));
1924 Set_Handler_List_Entry (N, Empty);
1926 elsif Is_Subprogram_Descriptor (N) then
1931 SDN := First (SD_List);
1932 while Present (SDN) loop
1933 if Defining_Identifier (N) = Entity (Prefix (SDN)) then
1946 end Check_Handler_Entry;
1948 -- Start of processing for Remove_Handler_Entries
1951 if Exception_Mechanism = Front_End_ZCX_Exceptions then
1952 Discard := Remove_All_Handler_Entries (N);
1954 end Remove_Handler_Entries;
OSDN Git Service
