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