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
|
-- Programmed by Jedidiah Barber
-- Released into the public domain
with
Ada.Assertions,
FLTK.Labels,
FLTK.Registry,
FLTK.Static,
Interfaces.C;
use type
FLTK.Static.Label_Draw_Function,
FLTK.Static.Label_Measure_Function;
package body FLTK.Label_Draw_Marshal is
package Chk renames Ada.Assertions;
Draw_Array : array (Label_Kind) of FLTK.Static.Label_Draw_Function;
Measure_Array : array (Label_Kind) of FLTK.Static.Label_Measure_Function;
procedure Label_Draw_Hook
(L : in Storage.Integer_Address;
X, Y, W, H : in Interfaces.C.int;
A : in Interfaces.Unsigned_16)
with Convention => C;
procedure Label_Draw_Hook
(L : in Storage.Integer_Address;
X, Y, W, H : in Interfaces.C.int;
A : in Interfaces.Unsigned_16)
is
My_Label : access FLTK.Labels.Label'Class;
begin
pragma Assert (FLTK.Registry.Label_Store.Contains (L));
My_Label := FLTK.Registry.Label_Store.Element (L);
Draw_Array (My_Label.Get_Kind)
(My_Label.all,
Integer (X), Integer (Y),
Integer (W), Integer (H),
Alignment (A));
exception
when Chk.Assertion_Error => raise Internal_FLTK_Error with
"Label_Draw_Hook was handed Label with no back reference to Ada in registry";
end Label_Draw_Hook;
procedure Label_Measure_Hook
(L : in Storage.Integer_Address;
W, H : out Interfaces.C.int)
with Convention => C;
procedure Label_Measure_Hook
(L : in Storage.Integer_Address;
W, H : out Interfaces.C.int)
is
My_Label : access FLTK.Labels.Label'Class;
begin
pragma Assert (FLTK.Registry.Label_Store.Contains (L));
My_Label := FLTK.Registry.Label_Store.Element (L);
Measure_Array (My_Label.Get_Kind)
(My_Label.all,
Integer (W), Integer (H));
exception
when Chk.Assertion_Error => raise Internal_FLTK_Error with
"Label_Measure_Hook was handed Label with no back reference to Ada in registry";
end Label_Measure_Hook;
function To_C
(Kind : in Label_Kind;
Func : in FLTK.Static.Label_Draw_Function)
return Storage.Integer_Address is
begin
if Func = null then
return Null_Pointer;
end if;
Draw_Array (Kind) := Func;
return Storage.To_Integer (Label_Draw_Hook'Address);
end To_C;
function To_C
(Kind : in Label_Kind;
Func : in FLTK.Static.Label_Measure_Function)
return Storage.Integer_Address is
begin
if Func = null then
return Null_Pointer;
end if;
Measure_Array (Kind) := Func;
return Storage.To_Integer (Label_Measure_Hook'Address);
end To_C;
end FLTK.Label_Draw_Marshal;
|
