diff 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
line wrap: on
line diff
--- a/gcc/ada/libgnat/a-except.adb	Fri Oct 27 22:46:09 2017 +0900
+++ b/gcc/ada/libgnat/a-except.adb	Thu Oct 25 07:37:49 2018 +0900
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2017, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2018, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -228,7 +228,7 @@
       function Allocate_Occurrence return EOA;
       --  Allocate an exception occurrence (as well as the machine occurrence)
 
-      procedure Propagate_Exception (Excep : EOA);
+      procedure Propagate_Exception (Excep : Exception_Occurrence);
       pragma No_Return (Propagate_Exception);
       --  This procedure propagates the exception represented by Excep
 
@@ -432,6 +432,8 @@
      (File : System.Address; Line : Integer);
    procedure Rcheck_PE_Bad_Predicated_Generic_Type
      (File : System.Address; Line : Integer);
+   procedure Rcheck_PE_Build_In_Place_Mismatch
+     (File : System.Address; Line : Integer);
    procedure Rcheck_PE_Current_Task_In_Entry_Body
      (File : System.Address; Line : Integer);
    procedure Rcheck_PE_Duplicated_Entry_Address
@@ -520,6 +522,8 @@
                   "__gnat_rcheck_PE_All_Guards_Closed");
    pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type,
                   "__gnat_rcheck_PE_Bad_Predicated_Generic_Type");
+   pragma Export (C, Rcheck_PE_Build_In_Place_Mismatch,
+                  "__gnat_rcheck_PE_Build_In_Place_Mismatch");
    pragma Export (C, Rcheck_PE_Current_Task_In_Entry_Body,
                   "__gnat_rcheck_PE_Current_Task_In_Entry_Body");
    pragma Export (C, Rcheck_PE_Duplicated_Entry_Address,
@@ -588,6 +592,7 @@
    pragma No_Return (Rcheck_PE_Aliased_Parameters);
    pragma No_Return (Rcheck_PE_All_Guards_Closed);
    pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type);
+   pragma No_Return (Rcheck_PE_Build_In_Place_Mismatch);
    pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body);
    pragma No_Return (Rcheck_PE_Duplicated_Entry_Address);
    pragma No_Return (Rcheck_PE_Explicit_Raise);
@@ -661,6 +666,7 @@
    Rmsg_34 : constant String := "infinite recursion"               & NUL;
    Rmsg_35 : constant String := "object too large"                 & NUL;
    Rmsg_36 : constant String := "stream operation not allowed"     & NUL;
+   Rmsg_37 : constant String := "build-in-place mismatch"          & NUL;
 
    -----------------------
    -- Polling Interface --
@@ -934,7 +940,7 @@
    procedure Complete_And_Propagate_Occurrence (X : EOA) is
    begin
       Complete_Occurrence (X);
-      Exception_Propagation.Propagate_Exception (X);
+      Exception_Propagation.Propagate_Exception (X.all);
    end Complete_And_Propagate_Occurrence;
 
    ---------------------
@@ -1085,7 +1091,7 @@
    is
    begin
       Exception_Propagation.Propagate_Exception
-        (Create_Occurrence_From_Signal_Handler (E, M));
+        (Create_Occurrence_From_Signal_Handler (E, M).all);
    end Raise_From_Signal_Handler;
 
    -------------------------
@@ -1335,6 +1341,13 @@
       Raise_Program_Error_Msg (File, Line, Rmsg_19'Address);
    end Rcheck_PE_Bad_Predicated_Generic_Type;
 
+   procedure Rcheck_PE_Build_In_Place_Mismatch
+     (File : System.Address; Line : Integer)
+   is
+   begin
+      Raise_Program_Error_Msg (File, Line, Rmsg_37'Address);
+   end Rcheck_PE_Build_In_Place_Mismatch;
+
    procedure Rcheck_PE_Current_Task_In_Entry_Body
      (File : System.Address; Line : Integer)
    is
@@ -1574,12 +1587,25 @@
    ---------------------------------
 
    procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
-      Excep    : constant EOA := Exception_Propagation.Allocate_Occurrence;
-      Saved_MO : constant System.Address := Excep.Machine_Occurrence;
    begin
-      Save_Occurrence (Excep.all, X);
-      Excep.Machine_Occurrence := Saved_MO;
-      Complete_And_Propagate_Occurrence (Excep);
+      --  If we have a Machine_Occurrence at hand already, e.g. when we are
+      --  reraising a foreign exception, just repropagate. Otherwise, e.g.
+      --  when reraising a GNAT exception or an occurrence read back from a
+      --  stream, set up a new occurrence with its own Machine block first.
+
+      if X.Machine_Occurrence /= System.Null_Address then
+         Exception_Propagation.Propagate_Exception (X);
+      else
+         declare
+            Excep : constant EOA
+              := Exception_Propagation.Allocate_Occurrence;
+            Saved_MO : constant System.Address := Excep.Machine_Occurrence;
+         begin
+            Save_Occurrence (Excep.all, X);
+            Excep.Machine_Occurrence := Saved_MO;
+            Complete_And_Propagate_Occurrence (Excep);
+         end;
+      end if;
    end Reraise_Occurrence_No_Defer;
 
    ---------------------