comparison gcc/ada/libgnat/a-except.adb @ 131:84e7813d76e9

gcc-8.2
author mir3636
date Thu, 25 Oct 2018 07:37:49 +0900
parents 04ced10e8804
children 1830386684a0
comparison
equal deleted inserted replaced
111:04ced10e8804 131:84e7813d76e9
4 -- -- 4 -- --
5 -- A D A . E X C E P T I O N S -- 5 -- A D A . E X C E P T I O N S --
6 -- -- 6 -- --
7 -- B o d y -- 7 -- B o d y --
8 -- -- 8 -- --
9 -- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- 9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
10 -- -- 10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under -- 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- -- 12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- -- 13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
226 --------------------------------------- 226 ---------------------------------------
227 227
228 function Allocate_Occurrence return EOA; 228 function Allocate_Occurrence return EOA;
229 -- Allocate an exception occurrence (as well as the machine occurrence) 229 -- Allocate an exception occurrence (as well as the machine occurrence)
230 230
231 procedure Propagate_Exception (Excep : EOA); 231 procedure Propagate_Exception (Excep : Exception_Occurrence);
232 pragma No_Return (Propagate_Exception); 232 pragma No_Return (Propagate_Exception);
233 -- This procedure propagates the exception represented by Excep 233 -- This procedure propagates the exception represented by Excep
234 234
235 end Exception_Propagation; 235 end Exception_Propagation;
236 236
429 procedure Rcheck_PE_Aliased_Parameters 429 procedure Rcheck_PE_Aliased_Parameters
430 (File : System.Address; Line : Integer); 430 (File : System.Address; Line : Integer);
431 procedure Rcheck_PE_All_Guards_Closed 431 procedure Rcheck_PE_All_Guards_Closed
432 (File : System.Address; Line : Integer); 432 (File : System.Address; Line : Integer);
433 procedure Rcheck_PE_Bad_Predicated_Generic_Type 433 procedure Rcheck_PE_Bad_Predicated_Generic_Type
434 (File : System.Address; Line : Integer);
435 procedure Rcheck_PE_Build_In_Place_Mismatch
434 (File : System.Address; Line : Integer); 436 (File : System.Address; Line : Integer);
435 procedure Rcheck_PE_Current_Task_In_Entry_Body 437 procedure Rcheck_PE_Current_Task_In_Entry_Body
436 (File : System.Address; Line : Integer); 438 (File : System.Address; Line : Integer);
437 procedure Rcheck_PE_Duplicated_Entry_Address 439 procedure Rcheck_PE_Duplicated_Entry_Address
438 (File : System.Address; Line : Integer); 440 (File : System.Address; Line : Integer);
518 "__gnat_rcheck_PE_Aliased_Parameters"); 520 "__gnat_rcheck_PE_Aliased_Parameters");
519 pragma Export (C, Rcheck_PE_All_Guards_Closed, 521 pragma Export (C, Rcheck_PE_All_Guards_Closed,
520 "__gnat_rcheck_PE_All_Guards_Closed"); 522 "__gnat_rcheck_PE_All_Guards_Closed");
521 pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type, 523 pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type,
522 "__gnat_rcheck_PE_Bad_Predicated_Generic_Type"); 524 "__gnat_rcheck_PE_Bad_Predicated_Generic_Type");
525 pragma Export (C, Rcheck_PE_Build_In_Place_Mismatch,
526 "__gnat_rcheck_PE_Build_In_Place_Mismatch");
523 pragma Export (C, Rcheck_PE_Current_Task_In_Entry_Body, 527 pragma Export (C, Rcheck_PE_Current_Task_In_Entry_Body,
524 "__gnat_rcheck_PE_Current_Task_In_Entry_Body"); 528 "__gnat_rcheck_PE_Current_Task_In_Entry_Body");
525 pragma Export (C, Rcheck_PE_Duplicated_Entry_Address, 529 pragma Export (C, Rcheck_PE_Duplicated_Entry_Address,
526 "__gnat_rcheck_PE_Duplicated_Entry_Address"); 530 "__gnat_rcheck_PE_Duplicated_Entry_Address");
527 pragma Export (C, Rcheck_PE_Explicit_Raise, 531 pragma Export (C, Rcheck_PE_Explicit_Raise,
586 pragma No_Return (Rcheck_PE_Accessibility_Check); 590 pragma No_Return (Rcheck_PE_Accessibility_Check);
587 pragma No_Return (Rcheck_PE_Address_Of_Intrinsic); 591 pragma No_Return (Rcheck_PE_Address_Of_Intrinsic);
588 pragma No_Return (Rcheck_PE_Aliased_Parameters); 592 pragma No_Return (Rcheck_PE_Aliased_Parameters);
589 pragma No_Return (Rcheck_PE_All_Guards_Closed); 593 pragma No_Return (Rcheck_PE_All_Guards_Closed);
590 pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type); 594 pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type);
595 pragma No_Return (Rcheck_PE_Build_In_Place_Mismatch);
591 pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body); 596 pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body);
592 pragma No_Return (Rcheck_PE_Duplicated_Entry_Address); 597 pragma No_Return (Rcheck_PE_Duplicated_Entry_Address);
593 pragma No_Return (Rcheck_PE_Explicit_Raise); 598 pragma No_Return (Rcheck_PE_Explicit_Raise);
594 pragma No_Return (Rcheck_PE_Implicit_Return); 599 pragma No_Return (Rcheck_PE_Implicit_Return);
595 pragma No_Return (Rcheck_PE_Misaligned_Address_Value); 600 pragma No_Return (Rcheck_PE_Misaligned_Address_Value);
659 Rmsg_32 : constant String := "empty storage pool" & NUL; 664 Rmsg_32 : constant String := "empty storage pool" & NUL;
660 Rmsg_33 : constant String := "explicit raise" & NUL; 665 Rmsg_33 : constant String := "explicit raise" & NUL;
661 Rmsg_34 : constant String := "infinite recursion" & NUL; 666 Rmsg_34 : constant String := "infinite recursion" & NUL;
662 Rmsg_35 : constant String := "object too large" & NUL; 667 Rmsg_35 : constant String := "object too large" & NUL;
663 Rmsg_36 : constant String := "stream operation not allowed" & NUL; 668 Rmsg_36 : constant String := "stream operation not allowed" & NUL;
669 Rmsg_37 : constant String := "build-in-place mismatch" & NUL;
664 670
665 ----------------------- 671 -----------------------
666 -- Polling Interface -- 672 -- Polling Interface --
667 ----------------------- 673 -----------------------
668 674
932 --------------------------------------- 938 ---------------------------------------
933 939
934 procedure Complete_And_Propagate_Occurrence (X : EOA) is 940 procedure Complete_And_Propagate_Occurrence (X : EOA) is
935 begin 941 begin
936 Complete_Occurrence (X); 942 Complete_Occurrence (X);
937 Exception_Propagation.Propagate_Exception (X); 943 Exception_Propagation.Propagate_Exception (X.all);
938 end Complete_And_Propagate_Occurrence; 944 end Complete_And_Propagate_Occurrence;
939 945
940 --------------------- 946 ---------------------
941 -- Raise_Exception -- 947 -- Raise_Exception --
942 --------------------- 948 ---------------------
1083 (E : Exception_Id; 1089 (E : Exception_Id;
1084 M : System.Address) 1090 M : System.Address)
1085 is 1091 is
1086 begin 1092 begin
1087 Exception_Propagation.Propagate_Exception 1093 Exception_Propagation.Propagate_Exception
1088 (Create_Occurrence_From_Signal_Handler (E, M)); 1094 (Create_Occurrence_From_Signal_Handler (E, M).all);
1089 end Raise_From_Signal_Handler; 1095 end Raise_From_Signal_Handler;
1090 1096
1091 ------------------------- 1097 -------------------------
1092 -- Raise_Program_Error -- 1098 -- Raise_Program_Error --
1093 ------------------------- 1099 -------------------------
1332 (File : System.Address; Line : Integer) 1338 (File : System.Address; Line : Integer)
1333 is 1339 is
1334 begin 1340 begin
1335 Raise_Program_Error_Msg (File, Line, Rmsg_19'Address); 1341 Raise_Program_Error_Msg (File, Line, Rmsg_19'Address);
1336 end Rcheck_PE_Bad_Predicated_Generic_Type; 1342 end Rcheck_PE_Bad_Predicated_Generic_Type;
1343
1344 procedure Rcheck_PE_Build_In_Place_Mismatch
1345 (File : System.Address; Line : Integer)
1346 is
1347 begin
1348 Raise_Program_Error_Msg (File, Line, Rmsg_37'Address);
1349 end Rcheck_PE_Build_In_Place_Mismatch;
1337 1350
1338 procedure Rcheck_PE_Current_Task_In_Entry_Body 1351 procedure Rcheck_PE_Current_Task_In_Entry_Body
1339 (File : System.Address; Line : Integer) 1352 (File : System.Address; Line : Integer)
1340 is 1353 is
1341 begin 1354 begin
1572 --------------------------------- 1585 ---------------------------------
1573 -- Reraise_Occurrence_No_Defer -- 1586 -- Reraise_Occurrence_No_Defer --
1574 --------------------------------- 1587 ---------------------------------
1575 1588
1576 procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is 1589 procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
1577 Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; 1590 begin
1578 Saved_MO : constant System.Address := Excep.Machine_Occurrence; 1591 -- If we have a Machine_Occurrence at hand already, e.g. when we are
1579 begin 1592 -- reraising a foreign exception, just repropagate. Otherwise, e.g.
1580 Save_Occurrence (Excep.all, X); 1593 -- when reraising a GNAT exception or an occurrence read back from a
1581 Excep.Machine_Occurrence := Saved_MO; 1594 -- stream, set up a new occurrence with its own Machine block first.
1582 Complete_And_Propagate_Occurrence (Excep); 1595
1596 if X.Machine_Occurrence /= System.Null_Address then
1597 Exception_Propagation.Propagate_Exception (X);
1598 else
1599 declare
1600 Excep : constant EOA
1601 := Exception_Propagation.Allocate_Occurrence;
1602 Saved_MO : constant System.Address := Excep.Machine_Occurrence;
1603 begin
1604 Save_Occurrence (Excep.all, X);
1605 Excep.Machine_Occurrence := Saved_MO;
1606 Complete_And_Propagate_Occurrence (Excep);
1607 end;
1608 end if;
1583 end Reraise_Occurrence_No_Defer; 1609 end Reraise_Occurrence_No_Defer;
1584 1610
1585 --------------------- 1611 ---------------------
1586 -- Save_Occurrence -- 1612 -- Save_Occurrence --
1587 --------------------- 1613 ---------------------