rxada_0.1.1_dd9da799/src/body/rx-errors.adb

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
with Ada.Unchecked_Deallocation;

package body Rx.Errors is

   ------------
   -- Create --
   ------------

   function Create (From : Ada.Exceptions.Exception_Occurrence) return Occurrence is
   begin
      return E : Occurrence do
         Fill (E, From);
      end return;
   end Create;

   ----------
   -- Fill --
   ----------

   procedure Fill
     (Error : out Occurrence;
      From  :     Ada.Exceptions.Exception_Occurrence)
   is
   begin
      if Error.Instance = null then
         Error.Instance := new Ada.Exceptions.Exception_Occurrence;
      end if;
      Ada.Exceptions.Save_Occurrence (Error.Instance.all, From);
   end Fill;

   -------------
   -- Reraise --
   -------------

   procedure Reraise (Error : Occurrence) is
   begin
      Ada.Exceptions.Reraise_Occurrence (Error.Instance.all);
   end Reraise;

   --------------
   -- Finalize --
   --------------

   overriding procedure Finalize   (E : in out Occurrence) is
      procedure Free is new Ada.Unchecked_Deallocation (Ada.Exceptions.Exception_Occurrence, Except_Access);
   begin
      Free (E.Instance);
   end Finalize;

   ------------
   -- Adjust --
   ------------

   overriding procedure Adjust     (E : in out Occurrence) is
      Mine : Except_Access;
   begin
      if E.Instance /= null then
         Mine := new Ada.Exceptions.Exception_Occurrence;
         Ada.Exceptions.Save_Occurrence (Mine.all, E.Instance.all);
         E.Instance := Mine;
      end if;
   end Adjust;

end Rx.Errors;