-- sale, use or other dealings in this Software without prior written --
-- authorization. --
------------------------------------------------------------------------------
--- Author: Juergen Pfeifer <Juergen.Pfeifer@T-Online.de> 1996
+-- Author: Juergen Pfeifer <juergen.pfeifer@gmx.net> 1996
-- Version Control:
--- $Revision: 1.13 $
--- Binding Version 00.93
+-- $Revision: 1.20 $
+-- Binding Version 01.00
------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
-with Unchecked_Conversion;
+with Ada.Unchecked_Conversion;
with Interfaces.C; use Interfaces.C;
with Interfaces.C.Strings; use Interfaces.C.Strings;
+with Interfaces.C.Pointers;
-with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
+with Terminal_Interface.Curses.Aux;
package body Terminal_Interface.Curses.Forms is
+ use Terminal_Interface.Curses.Aux;
+
+ type C_Field_Array is array (Natural range <>) of aliased Field;
+ package F_Array is new
+ Interfaces.C.Pointers (Natural, Field, C_Field_Array, Null_Field);
+
------------------------------------------------------------------------------
-- |
-- |
-- subtype chars_ptr is Interfaces.C.Strings.chars_ptr;
function FOS_2_CInt is new
- Unchecked_Conversion (Field_Option_Set,
- C_Int);
+ Ada.Unchecked_Conversion (Field_Option_Set,
+ C_Int);
function CInt_2_FOS is new
- Unchecked_Conversion (C_Int,
- Field_Option_Set);
+ Ada.Unchecked_Conversion (C_Int,
+ Field_Option_Set);
function FrmOS_2_CInt is new
- Unchecked_Conversion (Form_Option_Set,
- C_Int);
+ Ada.Unchecked_Conversion (Form_Option_Set,
+ C_Int);
function CInt_2_FrmOS is new
- Unchecked_Conversion (C_Int,
- Form_Option_Set);
+ Ada.Unchecked_Conversion (C_Int,
+ Form_Option_Set);
procedure Request_Name (Key : in Form_Request_Code;
Name : out String)
Buffer : in Buffer_Number := Buffer_Number'First;
Str : in String)
is
- type Char_Ptr is access all Interfaces.C.Char;
+ type Char_Ptr is access all Interfaces.C.char;
function Set_Fld_Buffer (Fld : Field;
Bufnum : C_Int;
S : Char_Ptr)
-- |
-- |
-- |
- procedure Normalize_Field_Options (Options : in out C_Int);
- pragma Import (C, Normalize_Field_Options, "_nc_ada_normalize_field_opts");
-
procedure Set_Options (Fld : in Field;
Options : in Field_Option_Set)
is
Opt : C_Int := FOS_2_CInt (Options);
Res : Eti_Error;
begin
- Normalize_Field_Options (Opt);
Res := Set_Field_Opts (Fld, Opt);
if Res /= E_Ok then
Eti_Exception (Res);
Err : Eti_Error;
Opt : C_Int := FOS_2_CInt (Options);
begin
- Normalize_Field_Options (Opt);
if On then
Err := Field_Opts_On (Fld, Opt);
else
Res : C_Int := Field_Opts (Fld);
begin
- Normalize_Field_Options (Res);
Options := CInt_2_FOS (Res);
end Get_Options;
-- |
Color : in Color_Pair := Color_Pair'First)
is
function Set_Field_Fore (Fld : Field;
- Attr : C_Int) return C_Int;
+ Attr : C_Chtype) return C_Int;
pragma Import (C, Set_Field_Fore, "set_field_fore");
Ch : constant Attributed_Character := (Ch => Character'First,
Color => Color,
Attr => Fore);
- Res : constant Eti_Error := Set_Field_Fore (Fld, Chtype_To_CInt (Ch));
+ Res : constant Eti_Error :=
+ Set_Field_Fore (Fld, AttrChar_To_Chtype (Ch));
begin
if Res /= E_Ok then
Eti_Exception (Res);
procedure Foreground (Fld : in Field;
Fore : out Character_Attribute_Set)
is
- function Field_Fore (Fld : Field) return C_Int;
+ function Field_Fore (Fld : Field) return C_Chtype;
pragma Import (C, Field_Fore, "field_fore");
begin
- Fore := CInt_To_Chtype (Field_Fore (Fld)).Attr;
+ Fore := Chtype_To_AttrChar (Field_Fore (Fld)).Attr;
end Foreground;
procedure Foreground (Fld : in Field;
Fore : out Character_Attribute_Set;
Color : out Color_Pair)
is
- function Field_Fore (Fld : Field) return C_Int;
+ function Field_Fore (Fld : Field) return C_Chtype;
pragma Import (C, Field_Fore, "field_fore");
begin
- Fore := CInt_To_Chtype (Field_Fore (Fld)).Attr;
- Color := CInt_To_Chtype (Field_Fore (Fld)).Color;
+ Fore := Chtype_To_AttrChar (Field_Fore (Fld)).Attr;
+ Color := Chtype_To_AttrChar (Field_Fore (Fld)).Color;
end Foreground;
-- |
-- |
Color : in Color_Pair := Color_Pair'First)
is
function Set_Field_Back (Fld : Field;
- Attr : C_Int) return C_Int;
+ Attr : C_Chtype) return C_Int;
pragma Import (C, Set_Field_Back, "set_field_back");
Ch : constant Attributed_Character := (Ch => Character'First,
Color => Color,
Attr => Back);
- Res : constant Eti_Error := Set_Field_Back (Fld, Chtype_To_CInt (Ch));
+ Res : constant Eti_Error :=
+ Set_Field_Back (Fld, AttrChar_To_Chtype (Ch));
begin
if Res /= E_Ok then
Eti_Exception (Res);
procedure Background (Fld : in Field;
Back : out Character_Attribute_Set)
is
- function Field_Back (Fld : Field) return C_Int;
+ function Field_Back (Fld : Field) return C_Chtype;
pragma Import (C, Field_Back, "field_back");
begin
- Back := CInt_To_Chtype (Field_Back (Fld)).Attr;
+ Back := Chtype_To_AttrChar (Field_Back (Fld)).Attr;
end Background;
procedure Background (Fld : in Field;
Back : out Character_Attribute_Set;
Color : out Color_Pair)
is
- function Field_Back (Fld : Field) return C_Int;
+ function Field_Back (Fld : Field) return C_Chtype;
pragma Import (C, Field_Back, "field_back");
begin
- Back := CInt_To_Chtype (Field_Back (Fld)).Attr;
- Color := CInt_To_Chtype (Field_Back (Fld)).Color;
+ Back := Chtype_To_AttrChar (Field_Back (Fld)).Attr;
+ Color := Chtype_To_AttrChar (Field_Back (Fld)).Color;
end Background;
-- |
-- |
function Fields (Frm : Form;
Index : Positive) return Field
is
- function F_Fields (Frm : Form;
- Idx : C_Int) return Field;
- pragma Import (C, F_Fields, "_nc_get_field");
+ use F_Array;
+
+ function C_Fields (Frm : Form) return Pointer;
+ pragma Import (C, C_Fields, "form_fields");
+
+ P : Pointer := C_Fields (Frm);
begin
- if Frm = Null_Form or else Index not in 1 .. Field_Count (Frm) then
+ if P = null or else Index not in 1 .. Field_Count (Frm) then
raise Form_Exception;
else
- return F_Fields (Frm, C_Int (Index) - 1);
+ P := P + ptrdiff_t (C_Int (Index) - 1);
+ return P.all;
end if;
end Fields;
-- |
-- |
-- |
-- |
- procedure Normalize_Form_Options (Options : in out C_Int);
- pragma Import (C, Normalize_Form_Options, "_nc_ada_normalize_form_opts");
-
procedure Set_Options (Frm : in Form;
Options : in Form_Option_Set)
is
Opt : C_Int := FrmOS_2_CInt (Options);
Res : Eti_Error;
begin
- Normalize_Form_Options (Opt);
Res := Set_Form_Opts (Frm, Opt);
if Res /= E_Ok then
Eti_Exception (Res);
Err : Eti_Error;
Opt : C_Int := FrmOS_2_CInt (Options);
begin
- Normalize_Form_Options (Opt);
if On then
Err := Form_Opts_On (Frm, Opt);
else
Res : C_Int := Form_Opts (Frm);
begin
- Normalize_Form_Options (Res);
Options := CInt_2_FrmOS (Res);
end Get_Options;
-- |
projects / ncurses.git / blobdiff