-- B O D Y --
-- --
------------------------------------------------------------------------------
--- Copyright (c) 1998 Free Software Foundation, Inc. --
+-- Copyright (c) 1998-2008,2009 Free Software Foundation, Inc. --
-- --
-- Permission is hereby granted, free of charge, to any person obtaining a --
-- copy of this software and associated documentation files (the --
-- sale, use or other dealings in this Software without prior written --
-- authorization. --
------------------------------------------------------------------------------
--- Author: Juergen Pfeifer <juergen.pfeifer@gmx.net> 1996
+-- Author: Juergen Pfeifer, 1996
-- Version Control:
--- $Revision: 1.20 $
+-- $Revision: 1.27 $
+-- $Date: 2009/12/26 17:38:58 $
-- Binding Version 01.00
------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
Ada.Unchecked_Conversion (C_Int,
Form_Option_Set);
- procedure Request_Name (Key : in Form_Request_Code;
+ procedure Request_Name (Key : Form_Request_Code;
Name : out String)
is
function Form_Request_Name (Key : C_Int) return chars_ptr;
-- |
-- |
-- |
- procedure Set_Justification (Fld : in Field;
- Just : in Field_Justification := None)
+ procedure Set_Justification (Fld : Field;
+ Just : Field_Justification := None)
is
function Set_Field_Just (Fld : Field;
Just : C_Int) return C_Int;
-- |
-- |
procedure Set_Buffer
- (Fld : in Field;
- Buffer : in Buffer_Number := Buffer_Number'First;
- Str : in String)
+ (Fld : Field;
+ Buffer : Buffer_Number := Buffer_Number'First;
+ Str : String)
is
type Char_Ptr is access all Interfaces.C.char;
function Set_Fld_Buffer (Fld : Field;
-- |
-- |
procedure Get_Buffer
- (Fld : in Field;
- Buffer : in Buffer_Number := Buffer_Number'First;
+ (Fld : Field;
+ Buffer : Buffer_Number := Buffer_Number'First;
Str : out String)
is
function Field_Buffer (Fld : Field;
end Get_Buffer;
function Get_Buffer
- (Fld : in Field;
- Buffer : in Buffer_Number := Buffer_Number'First) return String
+ (Fld : Field;
+ Buffer : Buffer_Number := Buffer_Number'First) return String
is
function Field_Buffer (Fld : Field;
B : C_Int) return chars_ptr;
-- |
-- |
-- |
- procedure Set_Status (Fld : in Field;
- Status : in Boolean := True)
+ procedure Set_Status (Fld : Field;
+ Status : Boolean := True)
is
function Set_Fld_Status (Fld : Field;
St : C_Int) return C_Int;
-- |
-- |
-- |
- procedure Set_Maximum_Size (Fld : in Field;
- Max : in Natural := 0)
+ procedure Set_Maximum_Size (Fld : Field;
+ Max : Natural := 0)
is
function Set_Field_Max (Fld : Field;
M : C_Int) return C_Int;
-- |
-- |
-- |
- procedure Set_Options (Fld : in Field;
- Options : in Field_Option_Set)
+ procedure Set_Options (Fld : Field;
+ Options : Field_Option_Set)
is
function Set_Field_Opts (Fld : Field;
Opt : C_Int) return C_Int;
pragma Import (C, Set_Field_Opts, "set_field_opts");
- Opt : C_Int := FOS_2_CInt (Options);
+ Opt : constant C_Int := FOS_2_CInt (Options);
Res : Eti_Error;
begin
Res := Set_Field_Opts (Fld, Opt);
-- |
-- |
-- |
- procedure Switch_Options (Fld : in Field;
- Options : in Field_Option_Set;
+ procedure Switch_Options (Fld : Field;
+ Options : Field_Option_Set;
On : Boolean := True)
is
function Field_Opts_On (Fld : Field;
pragma Import (C, Field_Opts_Off, "field_opts_off");
Err : Eti_Error;
- Opt : C_Int := FOS_2_CInt (Options);
+ Opt : constant C_Int := FOS_2_CInt (Options);
begin
if On then
Err := Field_Opts_On (Fld, Opt);
-- |
-- |
-- |
- procedure Get_Options (Fld : in Field;
+ procedure Get_Options (Fld : Field;
Options : out Field_Option_Set)
is
function Field_Opts (Fld : Field) return C_Int;
pragma Import (C, Field_Opts, "field_opts");
- Res : C_Int := Field_Opts (Fld);
+ Res : constant C_Int := Field_Opts (Fld);
begin
Options := CInt_2_FOS (Res);
end Get_Options;
-- |
-- |
procedure Set_Foreground
- (Fld : in Field;
- Fore : in Character_Attribute_Set := Normal_Video;
- Color : in Color_Pair := Color_Pair'First)
+ (Fld : Field;
+ Fore : Character_Attribute_Set := Normal_Video;
+ Color : Color_Pair := Color_Pair'First)
is
function Set_Field_Fore (Fld : Field;
Attr : C_Chtype) return C_Int;
-- |
-- |
-- |
- procedure Foreground (Fld : in Field;
+ procedure Foreground (Fld : Field;
Fore : out Character_Attribute_Set)
is
function Field_Fore (Fld : Field) return C_Chtype;
Fore := Chtype_To_AttrChar (Field_Fore (Fld)).Attr;
end Foreground;
- procedure Foreground (Fld : in Field;
+ procedure Foreground (Fld : Field;
Fore : out Character_Attribute_Set;
Color : out Color_Pair)
is
-- |
-- |
procedure Set_Background
- (Fld : in Field;
- Back : in Character_Attribute_Set := Normal_Video;
- Color : in Color_Pair := Color_Pair'First)
+ (Fld : Field;
+ Back : Character_Attribute_Set := Normal_Video;
+ Color : Color_Pair := Color_Pair'First)
is
function Set_Field_Back (Fld : Field;
Attr : C_Chtype) return C_Int;
-- |
-- |
-- |
- procedure Background (Fld : in Field;
+ procedure Background (Fld : Field;
Back : out Character_Attribute_Set)
is
function Field_Back (Fld : Field) return C_Chtype;
Back := Chtype_To_AttrChar (Field_Back (Fld)).Attr;
end Background;
- procedure Background (Fld : in Field;
+ procedure Background (Fld : Field;
Back : out Character_Attribute_Set;
Color : out Color_Pair)
is
-- |
-- |
-- |
- procedure Set_Pad_Character (Fld : in Field;
- Pad : in Character := Space)
+ procedure Set_Pad_Character (Fld : Field;
+ Pad : Character := Space)
is
function Set_Field_Pad (Fld : Field;
Ch : C_Int) return C_Int;
-- |
-- |
-- |
- procedure Pad_Character (Fld : in Field;
+ procedure Pad_Character (Fld : Field;
Pad : out Character)
is
function Field_Pad (Fld : Field) return C_Int;
-- |
-- |
-- |
- procedure Info (Fld : in Field;
+ procedure Info (Fld : Field;
Lines : out Line_Count;
Columns : out Column_Count;
First_Row : out Line_Position;
-- |
-- |
-- |
- procedure Dynamic_Info (Fld : in Field;
+ procedure Dynamic_Info (Fld : Field;
Lines : out Line_Count;
Columns : out Column_Count;
Max : out Natural)
-- |
-- |
-- |
- procedure Set_Window (Frm : in Form;
- Win : in Window)
+ procedure Set_Window (Frm : Form;
+ Win : Window)
is
function Set_Form_Win (Frm : Form;
Win : Window) return C_Int;
-- |
-- |
-- |
- procedure Set_Sub_Window (Frm : in Form;
- Win : in Window)
+ procedure Set_Sub_Window (Frm : Form;
+ Win : Window)
is
function Set_Form_Sub (Frm : Form;
Win : Window) return C_Int;
-- |
-- |
-- |
- procedure Scale (Frm : in Form;
+ procedure Scale (Frm : Form;
Lines : out Line_Count;
Columns : out Column_Count)
is
-- |
-- |
-- |
- procedure Set_Field_Init_Hook (Frm : in Form;
- Proc : in Form_Hook_Function)
+ procedure Set_Field_Init_Hook (Frm : Form;
+ Proc : Form_Hook_Function)
is
function Set_Field_Init (Frm : Form;
Proc : Form_Hook_Function) return C_Int;
-- |
-- |
-- |
- procedure Set_Field_Term_Hook (Frm : in Form;
- Proc : in Form_Hook_Function)
+ procedure Set_Field_Term_Hook (Frm : Form;
+ Proc : Form_Hook_Function)
is
function Set_Field_Term (Frm : Form;
Proc : Form_Hook_Function) return C_Int;
-- |
-- |
-- |
- procedure Set_Form_Init_Hook (Frm : in Form;
- Proc : in Form_Hook_Function)
+ procedure Set_Form_Init_Hook (Frm : Form;
+ Proc : Form_Hook_Function)
is
function Set_Form_Init (Frm : Form;
Proc : Form_Hook_Function) return C_Int;
-- |
-- |
-- |
- procedure Set_Form_Term_Hook (Frm : in Form;
- Proc : in Form_Hook_Function)
+ procedure Set_Form_Term_Hook (Frm : Form;
+ Proc : Form_Hook_Function)
is
function Set_Form_Term (Frm : Form;
Proc : Form_Hook_Function) return C_Int;
-- |
-- |
-- |
- procedure Redefine (Frm : in Form;
- Flds : in Field_Array_Access)
+ procedure Redefine (Frm : Form;
+ Flds : Field_Array_Access)
is
function Set_Frm_Fields (Frm : Form;
Items : System.Address) return C_Int;
P : Pointer := C_Fields (Frm);
begin
- if P = null or else Index not in 1 .. Field_Count (Frm) then
+ if P = null or else Index > Field_Count (Frm) then
raise Form_Exception;
else
P := P + ptrdiff_t (C_Int (Index) - 1);
-- |
-- |
-- |
- procedure Move (Fld : in Field;
- Line : in Line_Position;
- Column : in Column_Position)
+ procedure Move (Fld : Field;
+ Line : Line_Position;
+ Column : Column_Position)
is
function Move (Fld : Field; L, C : C_Int) return C_Int;
pragma Import (C, Move, "move_field");
-- |
-- |
-- |
- procedure Set_Options (Frm : in Form;
- Options : in Form_Option_Set)
+ procedure Set_Options (Frm : Form;
+ Options : Form_Option_Set)
is
function Set_Form_Opts (Frm : Form;
Opt : C_Int) return C_Int;
pragma Import (C, Set_Form_Opts, "set_form_opts");
- Opt : C_Int := FrmOS_2_CInt (Options);
+ Opt : constant C_Int := FrmOS_2_CInt (Options);
Res : Eti_Error;
begin
Res := Set_Form_Opts (Frm, Opt);
-- |
-- |
-- |
- procedure Switch_Options (Frm : in Form;
- Options : in Form_Option_Set;
+ procedure Switch_Options (Frm : Form;
+ Options : Form_Option_Set;
On : Boolean := True)
is
function Form_Opts_On (Frm : Form;
pragma Import (C, Form_Opts_Off, "form_opts_off");
Err : Eti_Error;
- Opt : C_Int := FrmOS_2_CInt (Options);
+ Opt : constant C_Int := FrmOS_2_CInt (Options);
begin
if On then
Err := Form_Opts_On (Frm, Opt);
-- |
-- |
-- |
- procedure Get_Options (Frm : in Form;
+ procedure Get_Options (Frm : Form;
Options : out Form_Option_Set)
is
function Form_Opts (Frm : Form) return C_Int;
pragma Import (C, Form_Opts, "form_opts");
- Res : C_Int := Form_Opts (Frm);
+ Res : constant C_Int := Form_Opts (Frm);
begin
Options := CInt_2_FrmOS (Res);
end Get_Options;
-- |
-- |
-- |
- procedure Post (Frm : in Form;
- Post : in Boolean := True)
+ procedure Post (Frm : Form;
+ Post : Boolean := True)
is
function M_Post (Frm : Form) return C_Int;
pragma Import (C, M_Post, "post_form");
function Frm_Driver (Frm : Form; Key : C_Int) return C_Int;
pragma Import (C, Frm_Driver, "form_driver");
- R : Eti_Error := Frm_Driver (Frm, C_Int (Key));
+ R : constant Eti_Error := Frm_Driver (Frm, C_Int (Key));
begin
if R /= E_Ok then
if R = E_Unknown_Command then
-- |
-- |
-- |
- procedure Set_Current (Frm : in Form;
- Fld : in Field)
+ procedure Set_Current (Frm : Form;
+ Fld : Field)
is
function Set_Current_Fld (Frm : Form; Fld : Field) return C_Int;
pragma Import (C, Set_Current_Fld, "set_current_field");
-- |
-- |
-- |
- function Current (Frm : in Form) return Field
+ function Current (Frm : Form) return Field
is
function Current_Fld (Frm : Form) return Field;
pragma Import (C, Current_Fld, "current_field");
-- |
-- |
-- |
- procedure Set_Page (Frm : in Form;
- Page : in Page_Number := Page_Number'First)
+ procedure Set_Page (Frm : Form;
+ Page : Page_Number := Page_Number'First)
is
function Set_Frm_Page (Frm : Form; Pg : C_Int) return C_Int;
pragma Import (C, Set_Frm_Page, "set_form_page");
-- |
-- |
-- |
- procedure Set_New_Page (Fld : in Field;
- New_Page : in Boolean := True)
+ procedure Set_New_Page (Fld : Field;
+ New_Page : Boolean := True)
is
function Set_Page (Fld : Field; Flg : C_Int) return C_Int;
pragma Import (C, Set_Page, "set_new_page");
end Is_New_Page;
procedure Free (FA : in out Field_Array_Access;
- Free_Fields : in Boolean := False)
+ Free_Fields : Boolean := False)
is
procedure Release is new Ada.Unchecked_Deallocation
(Field_Array, Field_Array_Access);
begin
if FA /= null and then Free_Fields then
for I in FA'First .. (FA'Last - 1) loop
- if (FA (I) /= Null_Field) then
+ if FA (I) /= Null_Field then
Delete (FA (I));
end if;
end loop;