?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* gcc.c (getenv_spec_function): New function.
[official-gcc.git] / gcc / ada / exp_ch11.adb
blob2312f504dd773541254ae3925baeed236a1931b9
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ C H 1 1 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
26
27 with Atree; use Atree;
28 with Casing; use Casing;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Errout; use Errout;
32 with Exp_Ch7; use Exp_Ch7;
33 with Exp_Util; use Exp_Util;
34 with Hostparm; use Hostparm;
35 with Namet; use Namet;
36 with Nlists; use Nlists;
37 with Nmake; use Nmake;
38 with Opt; use Opt;
39 with Rtsfind; use Rtsfind;
40 with Restrict; use Restrict;
41 with Rident; use Rident;
42 with Sem; use Sem;
43 with Sem_Ch8; use Sem_Ch8;
44 with Sem_Res; use Sem_Res;
45 with Sem_Util; use Sem_Util;
46 with Sinfo; use Sinfo;
47 with Sinput; use Sinput;
48 with Snames; use Snames;
49 with Stand; use Stand;
50 with Stringt; use Stringt;
51 with Targparm; use Targparm;
52 with Tbuild; use Tbuild;
53 with Uintp; use Uintp;
54
55 package body Exp_Ch11 is
56
57 ---------------------------
58 -- Expand_At_End_Handler --
59 ---------------------------
60
61 -- For a handled statement sequence that has a cleanup (At_End_Proc
62 -- field set), an exception handler of the following form is required:
63
64 -- exception
65 -- when all others =>
66 -- cleanup call
67 -- raise;
68
69 -- Note: this exception handler is treated rather specially by
70 -- subsequent expansion in two respects:
71
72 -- The normal call to Undefer_Abort is omitted
73 -- The raise call does not do Defer_Abort
74
75 -- This is because the current tasking code seems to assume that
76 -- the call to the cleanup routine that is made from an exception
77 -- handler for the abort signal is called with aborts deferred.
78
79 -- This expansion is only done if we have front end exception handling.
80 -- If we have back end exception handling, then the AT END handler is
81 -- left alone, and cleanups (including the exceptional case) are handled
82 -- by the back end.
83
84 -- In the front end case, the exception handler described above handles
85 -- the exceptional case. The AT END handler is left in the generated tree
86 -- and the code generator (e.g. gigi) must still handle proper generation
87 -- of cleanup calls for the non-exceptional case.
88
89 procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id) is
90 Clean : constant Entity_Id := Entity (At_End_Proc (HSS));
91 Loc : constant Source_Ptr := Sloc (Clean);
92 Ohandle : Node_Id;
93 Stmnts : List_Id;
94
95 begin
96 pragma Assert (Present (Clean));
97 pragma Assert (No (Exception_Handlers (HSS)));
98
99 -- Don't expand if back end exception handling active
100
101 if Exception_Mechanism = Back_End_Exceptions then
102 return;
103 end if;
104
105 -- Don't expand an At End handler if we have already had configurable
106 -- run-time violations, since likely this will just be a matter of
107 -- generating useless cascaded messages
108
109 if Configurable_Run_Time_Violations > 0 then
110 return;
111 end if;
112
113 if Restriction_Active (No_Exception_Handlers) then
114 return;
115 end if;
116
117 if Present (Block) then
118 New_Scope (Block);
119 end if;
120
121 Ohandle :=
122 Make_Others_Choice (Loc);
123 Set_All_Others (Ohandle);
124
125 Stmnts := New_List (
126 Make_Procedure_Call_Statement (Loc,
127 Name => New_Occurrence_Of (Clean, Loc)),
128 Make_Raise_Statement (Loc));
129
130 Set_Exception_Handlers (HSS, New_List (
131 Make_Exception_Handler (Loc,
132 Exception_Choices => New_List (Ohandle),
133 Statements => Stmnts)));
134
135 Analyze_List (Stmnts, Suppress => All_Checks);
136 Expand_Exception_Handlers (HSS);
137
138 if Present (Block) then
139 Pop_Scope;
140 end if;
141 end Expand_At_End_Handler;
142
143 -------------------------------
144 -- Expand_Exception_Handlers --
145 -------------------------------
146
147 procedure Expand_Exception_Handlers (HSS : Node_Id) is
148 Handlrs : constant List_Id := Exception_Handlers (HSS);
149 Loc : Source_Ptr;
150 Handler : Node_Id;
151 Others_Choice : Boolean;
152 Obj_Decl : Node_Id;
153
154 procedure Prepend_Call_To_Handler
155 (Proc : RE_Id;
156 Args : List_Id := No_List);
157 -- Routine to prepend a call to the procedure referenced by Proc at
158 -- the start of the handler code for the current Handler.
159
160 -----------------------------
161 -- Prepend_Call_To_Handler --
162 -----------------------------
163
164 procedure Prepend_Call_To_Handler
165 (Proc : RE_Id;
166 Args : List_Id := No_List)
167 is
168 Ent : constant Entity_Id := RTE (Proc);
169
170 begin
171 -- If we have no Entity, then we are probably in no run time mode
172 -- or some weird error has occured. In either case do do nothing!
173
174 if Present (Ent) then
175 declare
176 Call : constant Node_Id :=
177 Make_Procedure_Call_Statement (Loc,
178 Name => New_Occurrence_Of (RTE (Proc), Loc),
179 Parameter_Associations => Args);
180
181 begin
182 Prepend_To (Statements (Handler), Call);
183 Analyze (Call, Suppress => All_Checks);
184 end;
185 end if;
186 end Prepend_Call_To_Handler;
187
188 -- Start of processing for Expand_Exception_Handlers
189
190 begin
191 -- Loop through handlers
192
193 Handler := First_Non_Pragma (Handlrs);
194 Handler_Loop : while Present (Handler) loop
195 Loc := Sloc (Handler);
196
197 -- Remove source handler if gnat debug flag N is set
198
199 if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
200 declare
201 H : constant Node_Id := Handler;
202 begin
203 Next_Non_Pragma (Handler);
204 Remove (H);
205 goto Continue_Handler_Loop;
206 end;
207 end if;
208
209 -- If an exception occurrence is present, then we must declare it
210 -- and initialize it from the value stored in the TSD
211
212 -- declare
213 -- name : Exception_Occurrence;
214 --
215 -- begin
216 -- Save_Occurrence (name, Get_Current_Excep.all)
217 -- ...
218 -- end;
219
220 if Present (Choice_Parameter (Handler)) then
221 declare
222 Cparm : constant Entity_Id := Choice_Parameter (Handler);
223 Clc : constant Source_Ptr := Sloc (Cparm);
224 Save : Node_Id;
225
226 begin
227 Save :=
228 Make_Procedure_Call_Statement (Loc,
229 Name =>
230 New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc),
231 Parameter_Associations => New_List (
232 New_Occurrence_Of (Cparm, Clc),
233 Make_Explicit_Dereference (Loc,
234 Make_Function_Call (Loc,
235 Name => Make_Explicit_Dereference (Loc,
236 New_Occurrence_Of
237 (RTE (RE_Get_Current_Excep), Loc))))));
238
239 Mark_Rewrite_Insertion (Save);
240 Prepend (Save, Statements (Handler));
241
242 Obj_Decl :=
243 Make_Object_Declaration (Clc,
244 Defining_Identifier => Cparm,
245 Object_Definition =>
246 New_Occurrence_Of
247 (RTE (RE_Exception_Occurrence), Clc));
248 Set_No_Initialization (Obj_Decl, True);
249
250 Rewrite (Handler,
251 Make_Exception_Handler (Loc,
252 Exception_Choices => Exception_Choices (Handler),
253
254 Statements => New_List (
255 Make_Block_Statement (Loc,
256 Declarations => New_List (Obj_Decl),
257 Handled_Statement_Sequence =>
258 Make_Handled_Sequence_Of_Statements (Loc,
259 Statements => Statements (Handler))))));
260
261 Analyze_List (Statements (Handler), Suppress => All_Checks);
262 end;
263 end if;
264
265 -- The processing at this point is rather different for the
266 -- JVM case, so we completely separate the processing.
267
268 -- For the JVM case, we unconditionally call Update_Exception,
269 -- passing a call to the intrinsic function Current_Target_Exception
270 -- (see JVM version of Ada.Exceptions in 4jexcept.adb for details).
271
272 if Hostparm.Java_VM then
273 declare
274 Arg : constant Node_Id :=
275 Make_Function_Call (Loc,
276 Name => New_Occurrence_Of
277 (RTE (RE_Current_Target_Exception), Loc));
278 begin
279 Prepend_Call_To_Handler (RE_Update_Exception, New_List (Arg));
280 end;
281
282 -- For the normal case, we have to worry about the state of abort
283 -- deferral. Generally, we defer abort during runtime handling of
284 -- exceptions. When control is passed to the handler, then in the
285 -- normal case we undefer aborts. In any case this entire handling
286 -- is relevant only if aborts are allowed!
287
288 elsif Abort_Allowed then
289
290 -- There are some special cases in which we do not do the
291 -- undefer. In particular a finalization (AT END) handler
292 -- wants to operate with aborts still deferred.
293
294 -- We also suppress the call if this is the special handler
295 -- for Abort_Signal, since if we are aborting, we want to keep
296 -- aborts deferred (one abort is enough thank you very much :-)
297
298 -- If abort really needs to be deferred the expander must add
299 -- this call explicitly, see Exp_Ch9.Expand_N_Asynchronous_Select.
300
301 Others_Choice :=
302 Nkind (First (Exception_Choices (Handler))) = N_Others_Choice;
303
304 if (Others_Choice
305 or else Entity (First (Exception_Choices (Handler))) /=
306 Stand.Abort_Signal)
307 and then not
308 (Others_Choice
309 and then All_Others (First (Exception_Choices (Handler))))
310 and then Abort_Allowed
311 then
312 Prepend_Call_To_Handler (RE_Abort_Undefer);
313 end if;
314 end if;
315
316 Next_Non_Pragma (Handler);
317
318 <<Continue_Handler_Loop>>
319 null;
320 end loop Handler_Loop;
321
322 -- If all handlers got removed by gnatdN, then remove the list
323
324 if Debug_Flag_Dot_X
325 and then Is_Empty_List (Exception_Handlers (HSS))
326 then
327 Set_Exception_Handlers (HSS, No_List);
328 end if;
329 end Expand_Exception_Handlers;
330
331 ------------------------------------
332 -- Expand_N_Exception_Declaration --
333 ------------------------------------
334
335 -- Generates:
336 -- exceptE : constant String := "A.B.EXCEP"; -- static data
337 -- except : exception_data := (
338 -- Handled_By_Other => False,
339 -- Lang => 'A',
340 -- Name_Length => exceptE'Length,
341 -- Full_Name => exceptE'Address,
342 -- HTable_Ptr => null,
343 -- Import_Code => 0,
344 -- Raise_Hook => null,
345 -- );
346
347 -- (protecting test only needed if not at library level)
348 --
349 -- exceptF : Boolean := True -- static data
350 -- if exceptF then
351 -- exceptF := False;
352 -- Register_Exception (except'Unchecked_Access);
353 -- end if;
354
355 procedure Expand_N_Exception_Declaration (N : Node_Id) is
356 Loc : constant Source_Ptr := Sloc (N);
357 Id : constant Entity_Id := Defining_Identifier (N);
358 L : List_Id := New_List;
359 Flag_Id : Entity_Id;
360
361 Name_Exname : constant Name_Id := New_External_Name (Chars (Id), 'E');
362 Exname : constant Node_Id :=
363 Make_Defining_Identifier (Loc, Name_Exname);
364
365 begin
366 -- There is no expansion needed when compiling for the JVM since the
367 -- JVM has a built-in exception mechanism. See 4jexcept.ads for details.
368
369 if Hostparm.Java_VM then
370 return;
371 end if;
372
373 -- Definition of the external name: nam : constant String := "A.B.NAME";
374
375 Insert_Action (N,
376 Make_Object_Declaration (Loc,
377 Defining_Identifier => Exname,
378 Constant_Present => True,
379 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
380 Expression => Make_String_Literal (Loc, Full_Qualified_Name (Id))));
381
382 Set_Is_Statically_Allocated (Exname);
383
384 -- Create the aggregate list for type Standard.Exception_Type:
385 -- Handled_By_Other component: False
386
387 Append_To (L, New_Occurrence_Of (Standard_False, Loc));
388
389 -- Lang component: 'A'
390
391 Append_To (L,
392 Make_Character_Literal (Loc,
393 Chars => Name_uA,
394 Char_Literal_Value => UI_From_Int (Character'Pos ('A'))));
395
396 -- Name_Length component: Nam'Length
397
398 Append_To (L,
399 Make_Attribute_Reference (Loc,
400 Prefix => New_Occurrence_Of (Exname, Loc),
401 Attribute_Name => Name_Length));
402
403 -- Full_Name component: Standard.A_Char!(Nam'Address)
404
405 Append_To (L, Unchecked_Convert_To (Standard_A_Char,
406 Make_Attribute_Reference (Loc,
407 Prefix => New_Occurrence_Of (Exname, Loc),
408 Attribute_Name => Name_Address)));
409
410 -- HTable_Ptr component: null
411
412 Append_To (L, Make_Null (Loc));
413
414 -- Import_Code component: 0
415
416 Append_To (L, Make_Integer_Literal (Loc, 0));
417
418 -- Raise_Hook component: null
419
420 Append_To (L, Make_Null (Loc));
421
422 Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
423 Analyze_And_Resolve (Expression (N), Etype (Id));
424
425 -- Register_Exception (except'Unchecked_Access);
426
427 if not Restriction_Active (No_Exception_Handlers)
428 and then not Restriction_Active (No_Exception_Registration)
429 then
430 L := New_List (
431 Make_Procedure_Call_Statement (Loc,
432 Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc),
433 Parameter_Associations => New_List (
434 Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
435 Make_Attribute_Reference (Loc,
436 Prefix => New_Occurrence_Of (Id, Loc),
437 Attribute_Name => Name_Unrestricted_Access)))));
438
439 Set_Register_Exception_Call (Id, First (L));
440
441 if not Is_Library_Level_Entity (Id) then
442 Flag_Id := Make_Defining_Identifier (Loc,
443 New_External_Name (Chars (Id), 'F'));
444
445 Insert_Action (N,
446 Make_Object_Declaration (Loc,
447 Defining_Identifier => Flag_Id,
448 Object_Definition =>
449 New_Occurrence_Of (Standard_Boolean, Loc),
450 Expression =>
451 New_Occurrence_Of (Standard_True, Loc)));
452
453 Set_Is_Statically_Allocated (Flag_Id);
454
455 Append_To (L,
456 Make_Assignment_Statement (Loc,
457 Name => New_Occurrence_Of (Flag_Id, Loc),
458 Expression => New_Occurrence_Of (Standard_False, Loc)));
459
460 Insert_After_And_Analyze (N,
461 Make_Implicit_If_Statement (N,
462 Condition => New_Occurrence_Of (Flag_Id, Loc),
463 Then_Statements => L));
464
465 else
466 Insert_List_After_And_Analyze (N, L);
467 end if;
468 end if;
469
470 end Expand_N_Exception_Declaration;
471
472 ---------------------------------------------
473 -- Expand_N_Handled_Sequence_Of_Statements --
474 ---------------------------------------------
475
476 procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is
477 begin
478 if Present (Exception_Handlers (N))
479 and then not Restriction_Active (No_Exception_Handlers)
480 then
481 Expand_Exception_Handlers (N);
482 end if;
483
484 -- The following code needs comments ???
485
486 if Nkind (Parent (N)) /= N_Package_Body
487 and then Nkind (Parent (N)) /= N_Accept_Statement
488 and then Nkind (Parent (N)) /= N_Extended_Return_Statement
489 and then not Delay_Cleanups (Current_Scope)
490 then
491 Expand_Cleanup_Actions (Parent (N));
492 else
493 Set_First_Real_Statement (N, First (Statements (N)));
494 end if;
495
496 end Expand_N_Handled_Sequence_Of_Statements;
497
498 -------------------------------------
499 -- Expand_N_Raise_Constraint_Error --
500 -------------------------------------
501
502 -- The only processing required is to adjust the condition to deal
503 -- with the C/Fortran boolean case. This may well not be necessary,
504 -- as all such conditions are generated by the expander and probably
505 -- are all standard boolean, but who knows what strange optimization
506 -- in future may require this adjustment!
507
508 procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is
509 begin
510 Adjust_Condition (Condition (N));
511 end Expand_N_Raise_Constraint_Error;
512
513 ----------------------------------
514 -- Expand_N_Raise_Program_Error --
515 ----------------------------------
516
517 -- The only processing required is to adjust the condition to deal
518 -- with the C/Fortran boolean case. This may well not be necessary,
519 -- as all such conditions are generated by the expander and probably
520 -- are all standard boolean, but who knows what strange optimization
521 -- in future may require this adjustment!
522
523 procedure Expand_N_Raise_Program_Error (N : Node_Id) is
524 begin
525 Adjust_Condition (Condition (N));
526 end Expand_N_Raise_Program_Error;
527
528 ------------------------------
529 -- Expand_N_Raise_Statement --
530 ------------------------------
531
532 procedure Expand_N_Raise_Statement (N : Node_Id) is
533 Loc : constant Source_Ptr := Sloc (N);
534 Ehand : Node_Id;
535 E : Entity_Id;
536 Str : String_Id;
537
538 begin
539 -- If a string expression is present, then the raise statement is
540 -- converted to a call:
541
542 -- Raise_Exception (exception-name'Identity, string);
543
544 -- and there is nothing else to do
545
546 if Present (Expression (N)) then
547 Rewrite (N,
548 Make_Procedure_Call_Statement (Loc,
549 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
550 Parameter_Associations => New_List (
551 Make_Attribute_Reference (Loc,
552 Prefix => Name (N),
553 Attribute_Name => Name_Identity),
554 Expression (N))));
555 Analyze (N);
556 return;
557 end if;
558
559 -- Remaining processing is for the case where no string expression
560 -- is present.
561
562 -- There is no expansion needed for statement "raise <exception>;" when
563 -- compiling for the JVM since the JVM has a built-in exception
564 -- mechanism. However we need the keep the expansion for "raise;"
565 -- statements. See 4jexcept.ads for details.
566
567 if Present (Name (N)) and then Hostparm.Java_VM then
568 return;
569 end if;
570
571 -- Don't expand a raise statement that does not come from source
572 -- if we have already had configurable run-time violations, since
573 -- most likely it will be junk cascaded nonsense.
574
575 if Configurable_Run_Time_Violations > 0
576 and then not Comes_From_Source (N)
577 then
578 return;
579 end if;
580
581 -- Convert explicit raise of Program_Error, Constraint_Error, and
582 -- Storage_Error into the corresponding raise (in High_Integrity_Mode
583 -- all other raises will get normal expansion and be disallowed,
584 -- but this is also faster in all modes).
585
586 if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
587 if Entity (Name (N)) = Standard_Constraint_Error then
588 Rewrite (N,
589 Make_Raise_Constraint_Error (Loc,
590 Reason => CE_Explicit_Raise));
591 Analyze (N);
592 return;
593
594 elsif Entity (Name (N)) = Standard_Program_Error then
595 Rewrite (N,
596 Make_Raise_Program_Error (Loc,
597 Reason => PE_Explicit_Raise));
598 Analyze (N);
599 return;
600
601 elsif Entity (Name (N)) = Standard_Storage_Error then
602 Rewrite (N,
603 Make_Raise_Storage_Error (Loc,
604 Reason => SE_Explicit_Raise));
605 Analyze (N);
606 return;
607 end if;
608 end if;
609
610 -- Case of name present, in this case we expand raise name to
611
612 -- Raise_Exception (name'Identity, location_string);
613
614 -- where location_string identifies the file/line of the raise
615
616 if Present (Name (N)) then
617 declare
618 Id : Entity_Id := Entity (Name (N));
619
620 begin
621 Build_Location_String (Loc);
622
623 -- If the exception is a renaming, use the exception that it
624 -- renames (which might be a predefined exception, e.g.).
625
626 if Present (Renamed_Object (Id)) then
627 Id := Renamed_Object (Id);
628 end if;
629
630 -- Build a C-compatible string in case of no exception handlers,
631 -- since this is what the last chance handler is expecting.
632
633 if Restriction_Active (No_Exception_Handlers) then
634
635 -- Generate an empty message if configuration pragma
636 -- Suppress_Exception_Locations is set for this unit.
637
638 if Opt.Exception_Locations_Suppressed then
639 Name_Len := 1;
640 else
641 Name_Len := Name_Len + 1;
642 end if;
643
644 Name_Buffer (Name_Len) := ASCII.NUL;
645 end if;
646
647 if Opt.Exception_Locations_Suppressed then
648 Name_Len := 0;
649 end if;
650
651 Str := String_From_Name_Buffer;
652
653 -- For VMS exceptions, convert the raise into a call to
654 -- lib$stop so it will be handled by __gnat_error_handler.
655
656 if Is_VMS_Exception (Id) then
657 declare
658 Excep_Image : String_Id;
659 Cond : Node_Id;
660
661 begin
662 if Present (Interface_Name (Id)) then
663 Excep_Image := Strval (Interface_Name (Id));
664 else
665 Get_Name_String (Chars (Id));
666 Set_All_Upper_Case;
667 Excep_Image := String_From_Name_Buffer;
668 end if;
669
670 if Exception_Code (Id) /= No_Uint then
671 Cond :=
672 Make_Integer_Literal (Loc, Exception_Code (Id));
673 else
674 Cond :=
675 Unchecked_Convert_To (Standard_Integer,
676 Make_Function_Call (Loc,
677 Name => New_Occurrence_Of
678 (RTE (RE_Import_Value), Loc),
679 Parameter_Associations => New_List
680 (Make_String_Literal (Loc,
681 Strval => Excep_Image))));
682 end if;
683
684 Rewrite (N,
685 Make_Procedure_Call_Statement (Loc,
686 Name =>
687 New_Occurrence_Of (RTE (RE_Lib_Stop), Loc),
688 Parameter_Associations => New_List (Cond)));
689 Analyze_And_Resolve (Cond, Standard_Integer);
690 end;
691
692 -- Not VMS exception case, convert raise to call to the
693 -- Raise_Exception routine.
694
695 else
696 Rewrite (N,
697 Make_Procedure_Call_Statement (Loc,
698 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
699 Parameter_Associations => New_List (
700 Make_Attribute_Reference (Loc,
701 Prefix => Name (N),
702 Attribute_Name => Name_Identity),
703 Make_String_Literal (Loc,
704 Strval => Str))));
705 end if;
706 end;
707
708 -- Case of no name present (reraise). We rewrite the raise to:
709
710 -- Reraise_Occurrence_Always (EO);
711
712 -- where EO is the current exception occurrence. If the current handler
713 -- does not have a choice parameter specification, then we provide one.
714
715 else
716 -- Find innermost enclosing exception handler (there must be one,
717 -- since the semantics has already verified that this raise statement
718 -- is valid, and a raise with no arguments is only permitted in the
719 -- context of an exception handler.
720
721 Ehand := Parent (N);
722 while Nkind (Ehand) /= N_Exception_Handler loop
723 Ehand := Parent (Ehand);
724 end loop;
725
726 -- Make exception choice parameter if none present. Note that we do
727 -- not need to put the entity on the entity chain, since no one will
728 -- be referencing this entity by normal visibility methods.
729
730 if No (Choice_Parameter (Ehand)) then
731 E := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
732 Set_Choice_Parameter (Ehand, E);
733 Set_Ekind (E, E_Variable);
734 Set_Etype (E, RTE (RE_Exception_Occurrence));
735 Set_Scope (E, Current_Scope);
736 end if;
737
738 -- Now rewrite the raise as a call to Reraise. A special case arises
739 -- if this raise statement occurs in the context of a handler for
740 -- all others (i.e. an at end handler). in this case we avoid
741 -- the call to defer abort, cleanup routines are expected to be
742 -- called in this case with aborts deferred.
743
744 declare
745 Ech : constant Node_Id := First (Exception_Choices (Ehand));
746 Ent : Entity_Id;
747
748 begin
749 if Nkind (Ech) = N_Others_Choice
750 and then All_Others (Ech)
751 then
752 Ent := RTE (RE_Reraise_Occurrence_No_Defer);
753 else
754 Ent := RTE (RE_Reraise_Occurrence_Always);
755 end if;
756
757 Rewrite (N,
758 Make_Procedure_Call_Statement (Loc,
759 Name => New_Occurrence_Of (Ent, Loc),
760 Parameter_Associations => New_List (
761 New_Occurrence_Of (Choice_Parameter (Ehand), Loc))));
762 end;
763 end if;
764
765 Analyze (N);
766 end Expand_N_Raise_Statement;
767
768 ----------------------------------
769 -- Expand_N_Raise_Storage_Error --
770 ----------------------------------
771
772 -- The only processing required is to adjust the condition to deal
773 -- with the C/Fortran boolean case. This may well not be necessary,
774 -- as all such conditions are generated by the expander and probably
775 -- are all standard boolean, but who knows what strange optimization
776 -- in future may require this adjustment!
777
778 procedure Expand_N_Raise_Storage_Error (N : Node_Id) is
779 begin
780 Adjust_Condition (Condition (N));
781 end Expand_N_Raise_Storage_Error;
782
783 ------------------------------
784 -- Expand_N_Subprogram_Info --
785 ------------------------------
786
787 procedure Expand_N_Subprogram_Info (N : Node_Id) is
788 Loc : constant Source_Ptr := Sloc (N);
789
790 begin
791 -- For now, we replace an Expand_N_Subprogram_Info node with an
792 -- attribute reference that gives the address of the procedure.
793 -- This is because gigi does not yet recognize this node, and
794 -- for the initial targets, this is the right value anyway.
795
796 Rewrite (N,
797 Make_Attribute_Reference (Loc,
798 Prefix => Identifier (N),
799 Attribute_Name => Name_Code_Address));
800
801 Analyze_And_Resolve (N, RTE (RE_Code_Loc));
802 end Expand_N_Subprogram_Info;
803
804 ----------------------
805 -- Is_Non_Ada_Error --
806 ----------------------
807
808 function Is_Non_Ada_Error (E : Entity_Id) return Boolean is
809 begin
810 if not OpenVMS_On_Target then
811 return False;
812 end if;
813
814 Get_Name_String (Chars (E));
815
816 -- Note: it is a little irregular for the body of exp_ch11 to know
817 -- the details of the encoding scheme for names, but on the other
818 -- hand, gigi knows them, and this is for gigi's benefit anyway!
819
820 if Name_Buffer (1 .. 30) /= "system__aux_dec__non_ada_error" then
821 return False;
822 end if;
823
824 return True;
825 end Is_Non_Ada_Error;
826
827 end Exp_Ch11;
Mirror of the offical gcc git repository hosted at gcc.gnu.org