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
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168 | with Ada.Unchecked_Deallocation;
package body Agpl.Generic_Handle is
------------
-- Adjust --
------------
procedure Adjust (This : in out Object) is
begin
if This.Data /= null then
This.Data := new Item'(This.Data.all);
end if;
end Adjust;
-----------
-- Clear --
-----------
procedure Clear (This : in out Object) is
begin
Finalize (This);
end Clear;
--------------
-- Finalize --
--------------
procedure Finalize (This : in out Object) is
procedure Free is new Ada.Unchecked_Deallocation (Item, Item_Access);
begin
Free (This.Data);
end Finalize;
---------
-- Set --
---------
function Set (This : in Item) return Object is
begin
return (Ada.Finalization.Controlled with
Data => new Item'(This));
end Set;
---------
-- Set --
---------
function Set (This : in Item_Access) return Object is
begin
return (Ada.Finalization.Controlled with Data => This);
end Set;
---------
-- Set --
---------
procedure Set (This : in out Object; X : in Item) is
begin
This := Set (X);
end Set;
---------
-- Set --
---------
procedure Set (This : in out Object; X : in Item_Access) is
begin
This := Set (X);
end Set;
---------
-- Get --
---------
function Get (This : in Object) return Item is
begin
if This.Data = null then
raise No_Data;
else
return This.Data.all;
end if;
end Get;
-----------------
-- Null_Object --
-----------------
function Null_Object return Object is
begin
return (Ada.Finalization.Controlled with null);
end Null_Object;
---------
-- Ref --
---------
function Ref (This : in Object) return Item_Access is
begin
if This.Data = null then
raise No_Data;
else
return This.Data;
end if;
end Ref;
--------------
-- Is_Valid --
--------------
function Is_Valid (This : in Object) return Boolean is
begin
return This.Data /= null;
end Is_Valid;
----------
-- Read --
----------
-- We use a boolean to signal a valid data in the stream.
-- This is a waste since a byte would suffice, but I don't care.
procedure Read (Stream : access Ada.Streams.Root_Stream_Type'Class;
This : out Object)
is
Valid : Boolean := False;
begin
Finalize (This);
Boolean'Read (Stream, Valid);
if Valid then
This.Data := new Item'(Item'Input (Stream));
end if;
end Read;
-----------
-- Write --
-----------
procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class;
This : in Object)
is
begin
if This.Data = null then
Boolean'Write (Stream, False);
else
Boolean'Write (Stream, True);
Item'Output (Stream, This.Data.all);
end if;
end Write;
---------
-- "=" --
---------
function "=" (L, R : Object) return Boolean is
begin
if not L.Is_Valid and then not R.Is_Valid then
return True;
end if;
if L.Is_Valid and then R.Is_Valid then
return L.Ref.all = R.Ref.all;
end if;
return False;
end "=";
end Agpl.Generic_Handle;
|