rxada_0.1.1_dd9da799/src/body/rx-tools-holders.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
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
with Ada.Unchecked_Deallocation;

with Gnat.IO; use Gnat.IO;

with Rx.Debug;

package body Rx.Tools.Holders is

   function "+" (I : Indef) return Definite is
   begin
      return (Controlled with Actual => new Indef'(I));
   end "+";

   ----------
   -- Hold --
   ----------

   procedure Hold (D : in out Definite; I : Indef) is
   begin
      if D.Actual /= null then
         D.Finalize;
      end if;
      D.Actual := new Indef'(I);
   end Hold;

   ----------------
   -- Initialize --
   ----------------

   overriding procedure Initialize (D : in out Definite) is
   begin
      if D.Actual /= null then
         --           Put_Line ("initialize");
         raise Program_Error;
      end if;
   end Initialize;

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

   overriding procedure Adjust (D : in out Definite) is
   begin
      if D.Actual /= null then
         D.Actual := new Indef'(D.Actual.all);
      end if;
   exception
      when others =>
         Put_Line (Id & ": alloc exception (adjust)");
--           Rx.Debug.Print (E);
         raise;
   end Adjust;

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

   overriding procedure Finalize (D : in out Definite) is
      procedure Free is new Ada.Unchecked_Deallocation (Indef, Indef_Access);
   begin
      if D.Actual /= null then
         Free (D.Actual);
      end if;
   exception
      when E : others =>
         Put_Line (Id & ": alloc exception (finalize)");
         Rx.Debug.Print (E);
         raise;
   end Finalize;

   ---------
   -- Ref --
   ---------

   function Ref  (D : in out Definite) return Reference is
   begin
      return Reference'(Actual => D.Actual);
   end Ref;

   ----------
   -- CRef --
   ----------

   function CRef (D : Definite) return Const_Ref is (Actual => D.Actual);

end Rx.Tools.Holders;