13d2885fdad58a1d7c1e4fc01eee20ee4624a84d
[ncurses.git] / Ada95 / ada_include / terminal_interface-curses-forms-field_types.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                           GNAT ncurses Binding                           --
4 --                                                                          --
5 --                 Terminal_Interface.Curses.Forms.Field_Types              --
6 --                                                                          --
7 --                                 B O D Y                                  --
8 --                                                                          --
9 --  Version 00.92                                                           --
10 --                                                                          --
11 --  The ncurses Ada95 binding is copyrighted 1996 by                        --
12 --  Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de                     --
13 --                                                                          --
14 --  Permission is hereby granted to reproduce and distribute this           --
15 --  binding by any means and for any fee, whether alone or as part          --
16 --  of a larger distribution, in source or in binary form, PROVIDED         --
17 --  this notice is included with any such distribution, and is not          --
18 --  removed from any of its header files. Mention of ncurses and the        --
19 --  author of this binding in any applications linked with it is            --
20 --  highly appreciated.                                                     --
21 --                                                                          --
22 --  This binding comes AS IS with no warranty, implied or expressed.        --
23 ------------------------------------------------------------------------------
24 --  Version Control:
25 --  $Revision: 1.4 $
26 ------------------------------------------------------------------------------
27 with Interfaces.C;
28 with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
29 with Unchecked_Deallocation;
30
31 --  |
32 --  |=====================================================================
33 --  | man page form_fieldtype.3x
34 --  |=====================================================================
35 --  |
36 package body Terminal_Interface.Curses.Forms.Field_Types is
37
38    use type Interfaces.C.int;
39
40    type F_Check is access
41       function (Fld : Field; Info : User_Access) return C_Int;
42    pragma Convention (C, F_Check);
43
44    type C_Check is access
45       function (Ch : Character; Info : User_Access) return C_Int;
46    pragma Convention (C, C_Check);
47
48    procedure Free is new
49      Unchecked_Deallocation (User, User_Access);
50
51    --  Forward decls.
52    procedure Register_Field_Type;
53    procedure Unregister_Field_Type;
54
55    procedure Initialize (Obj : in out Tracker)
56    is
57    begin
58       Register_Field_Type;
59    end Initialize;
60
61    procedure Finalize (Obj : in out Tracker)
62    is
63    begin
64       Unregister_Field_Type;
65    end Finalize;
66
67    function Fc (Fld : Field; Info : User_Access) return C_Int;
68    pragma Convention (C, Fc);
69
70    function Cc (Ch : Character; Info : User_Access) return C_Int;
71    pragma Convention (C, Cc);
72
73    function Make_Arg (U : User_Access) return User_Access;
74    pragma Convention (C, Make_Arg);
75
76    function Copy_Arg (U : User_Access) return User_Access;
77    pragma Convention (C, Copy_Arg);
78
79    procedure Free_Arg (U : User_Access);
80    pragma Convention (C, Free_Arg);
81
82    function New_Fieldtype (Fc : F_Check;
83                            Cc : C_Check) return C_Field_Type;
84    pragma Import (C, New_Fieldtype, "new_fieldtype");
85
86    function Fc (Fld : Field; Info : User_Access) return C_Int
87    is
88    begin
89       return C_Int (Boolean'Pos (Field_Check (Fld, Info)));
90    end Fc;
91
92    function Cc (Ch : Character; Info : User_Access) return C_Int
93    is
94    begin
95       return C_Int (Boolean'Pos (Character_Check (Ch, Info)));
96    end Cc;
97
98    function Make_Arg (U : User_Access) return User_Access
99    is
100       function Fixme (U : User_Access) return User_Access;
101       pragma Import (C, Fixme, "_nc_ada_getvarg");
102       V : constant User_Access := Fixme (U);
103       I : constant User_Access := new User'(V.all);
104    begin
105       return I;
106    end Make_Arg;
107
108    function Copy_Arg (U : User_Access) return User_Access
109    is
110       I : constant User_Access := new User'(U.all);
111    begin
112       return I;
113    end Copy_Arg;
114
115    procedure Free_Arg (U : User_Access)
116    is
117    begin
118       null;
119    end Free_Arg;
120
121    type M_Arg is access function (U : User_Access) return User_Access;
122    pragma Convention (C, M_Arg);
123
124    type C_Arg is access function (U : User_Access) return User_Access;
125    pragma Convention (C, C_Arg);
126
127    type F_Arg is access procedure (U : User_Access);
128    pragma Convention (C, F_Arg);
129
130    function Set_Fieldtype_Arg (Typ : C_Field_Type;
131                                Ma  : M_Arg;
132                                Ca  : C_Arg;
133                                Fa  : F_Arg) return C_Int;
134    pragma Import (C, Set_Fieldtype_Arg, "set_fieldtype_arg");
135    --  |
136    --  |
137    --  |
138
139    procedure Register_Field_Type
140    is
141       Res : Eti_Error;
142       Cft : C_Field_Type;
143       P   : User_Access := new User;
144       --  we need an instance to call
145       --  the Register_Type procedure
146    begin
147       Cft := New_Fieldtype (Fc'Access,
148                             Cc'Access);
149       if Cft = Null_Field_Type then
150          raise Form_Exception;
151       end if;
152       Res := Set_Fieldtype_Arg (Cft,
153                                 Make_Arg'Access,
154                                 Copy_Arg'Access,
155                                 Free_Arg'Access);
156       if Res /= E_Ok then
157          Eti_Exception (Res);
158       end if;
159
160       Register_Type (P.all, Cft);
161       Free (P);
162    end Register_Field_Type;
163    --  |
164    --  |
165    --  |
166    procedure Unregister_Field_Type
167    is
168       P : User_Access := new User;
169       --  we need an instance to call
170       --  the Unregister_Type procedure
171    begin
172       Unregister_Type (P.all);
173       Free (P);
174    end Unregister_Field_Type;
175
176    Hook : Tracker;
177 end Terminal_Interface.Curses.Forms.Field_Types;
178
179
180
181
182