Mercurial > hg > CbC > CbC_gcc
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 --------------------- |