X-Git-Url: https://ncurses.scripts.mit.edu/?p=ncurses.git;a=blobdiff_plain;f=doc%2Fhtml%2Fada%2Fterminal_interface-curses-menus__adb.htm;h=73ec35a06e488f4176beea4d93fc5137602cc675;hp=f1338438f3b02e1c8fe4613819067ffd4672218e;hb=f86cbeb5f9bd96ab041d34039c35749a14965039;hpb=46722468f47c2b77b3987729b4bcf2321cccfd01 diff --git a/doc/html/ada/terminal_interface-curses-menus__adb.htm b/doc/html/ada/terminal_interface-curses-menus__adb.htm index f1338438..73ec35a0 100644 --- a/doc/html/ada/terminal_interface-curses-menus__adb.htm +++ b/doc/html/ada/terminal_interface-curses-menus__adb.htm @@ -1,3 +1,4 @@ + terminal_interface-curses-menus.adb

File : terminal_interface-curses-menus.adb

@@ -11,7 +12,7 @@ -- 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 -- @@ -37,991 +38,991 @@ -- sale, use or other dealings in this Software without prior written -- -- authorization. -- ------------------------------------------------------------------------------ --- Author: Jürgen Pfeifer, 1996 --- Contact: www.familiepfeifer.de/Contact.aspx?Lang=en +-- Author: Juergen Pfeifer, 1996 -- Version Control: --- @Revision: 1.21 @ +-- @Revision: 1.27 @ +-- @Date: 2009/12/26 17:38:58 @ -- Binding Version 01.00 ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; -with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; +with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; -with Interfaces.C; use Interfaces.C; -with Interfaces.C.Strings; use Interfaces.C.Strings; -with Interfaces.C.Pointers; +with Interfaces.C; use Interfaces.C; +with Interfaces.C.Strings; use Interfaces.C.Strings; +with Interfaces.C.Pointers; with Ada.Unchecked_Conversion; -package body Terminal_Interface.Curses.Menus is +package body Terminal_Interface.Curses.Menus is - type C_Item_Array is array (Natural range <>) of aliased Item; - package I_Array is new - Interfaces.C.Pointers (Natural, Item, C_Item_Array, Null_Item); + type C_Item_Array is array (Natural range <>) of aliased Item; + package I_Array is new + Interfaces.C.Pointers (Natural, Item, C_Item_Array, Null_Item); use type System.Bit_Order; - subtype chars_ptr is Interfaces.C.Strings.chars_ptr; + subtype chars_ptr is Interfaces.C.Strings.chars_ptr; - function MOS_2_CInt is new - Ada.Unchecked_Conversion (Menu_Option_Set, - C_Int); + function MOS_2_CInt is new + Ada.Unchecked_Conversion (Menu_Option_Set, + C_Int); - function CInt_2_MOS is new - Ada.Unchecked_Conversion (C_Int, - Menu_Option_Set); + function CInt_2_MOS is new + Ada.Unchecked_Conversion (C_Int, + Menu_Option_Set); - function IOS_2_CInt is new - Ada.Unchecked_Conversion (Item_Option_Set, - C_Int); + function IOS_2_CInt is new + Ada.Unchecked_Conversion (Item_Option_Set, + C_Int); - function CInt_2_IOS is new - Ada.Unchecked_Conversion (C_Int, - Item_Option_Set); + function CInt_2_IOS is new + Ada.Unchecked_Conversion (C_Int, + Item_Option_Set); ------------------------------------------------------------------------------ - procedure Request_Name (Key : in Menu_Request_Code; - Name : out String) + procedure Request_Name (Key : Menu_Request_Code; + Name : out String) is - function Request_Name (Key : C_Int) return chars_ptr; - pragma Import (C, Request_Name, "menu_request_name"); + function Request_Name (Key : C_Int) return chars_ptr; + pragma Import (C, Request_Name, "menu_request_name"); begin - Fill_String (Request_Name (C_Int (Key)), Name); - end Request_Name; + Fill_String (Request_Name (C_Int (Key)), Name); + end Request_Name; - function Request_Name (Key : Menu_Request_Code) return String + function Request_Name (Key : Menu_Request_Code) return String is - function Request_Name (Key : C_Int) return chars_ptr; - pragma Import (C, Request_Name, "menu_request_name"); + function Request_Name (Key : C_Int) return chars_ptr; + pragma Import (C, Request_Name, "menu_request_name"); begin - return Fill_String (Request_Name (C_Int (Key))); - end Request_Name; + return Fill_String (Request_Name (C_Int (Key))); + end Request_Name; - function Create (Name : String; - Description : String := "") return Item + function Create (Name : String; + Description : String := "") return Item is - type Char_Ptr is access all Interfaces.C.char; - function Newitem (Name, Desc : Char_Ptr) return Item; - pragma Import (C, Newitem, "new_item"); + type Char_Ptr is access all Interfaces.C.char; + function Newitem (Name, Desc : Char_Ptr) return Item; + pragma Import (C, Newitem, "new_item"); - type Name_String is new char_array (0 .. Name'Length); - type Name_String_Ptr is access Name_String; - pragma Controlled (Name_String_Ptr); + type Name_String is new char_array (0 .. Name'Length); + type Name_String_Ptr is access Name_String; + pragma Controlled (Name_String_Ptr); - type Desc_String is new char_array (0 .. Description'Length); - type Desc_String_Ptr is access Desc_String; - pragma Controlled (Desc_String_Ptr); + type Desc_String is new char_array (0 .. Description'Length); + type Desc_String_Ptr is access Desc_String; + pragma Controlled (Desc_String_Ptr); - Name_Str : Name_String_Ptr := new Name_String; - Desc_Str : Desc_String_Ptr := new Desc_String; - Name_Len, Desc_Len : size_t; - Result : Item; + Name_Str : constant Name_String_Ptr := new Name_String; + Desc_Str : constant Desc_String_Ptr := new Desc_String; + Name_Len, Desc_Len : size_t; + Result : Item; begin - To_C (Name, Name_Str.all, Name_Len); - To_C (Description, Desc_Str.all, Desc_Len); - Result := Newitem (Name_Str.all (Name_Str.all'First)'Access, - Desc_Str.all (Desc_Str.all'First)'Access); - if Result = Null_Item then - raise Eti_System_Error; + To_C (Name, Name_Str.all, Name_Len); + To_C (Description, Desc_Str.all, Desc_Len); + Result := Newitem (Name_Str.all (Name_Str.all'First)'Access, + Desc_Str.all (Desc_Str.all'First)'Access); + if Result = Null_Item then + raise Eti_System_Error; end if; - return Result; - end Create; + return Result; + end Create; - procedure Delete (Itm : in out Item) + procedure Delete (Itm : in out Item) is - function Descname (Itm : Item) return chars_ptr; - pragma Import (C, Descname, "item_description"); - function Itemname (Itm : Item) return chars_ptr; - pragma Import (C, Itemname, "item_name"); + function Descname (Itm : Item) return chars_ptr; + pragma Import (C, Descname, "item_description"); + function Itemname (Itm : Item) return chars_ptr; + pragma Import (C, Itemname, "item_name"); - function Freeitem (Itm : Item) return C_Int; - pragma Import (C, Freeitem, "free_item"); + function Freeitem (Itm : Item) return C_Int; + pragma Import (C, Freeitem, "free_item"); - Res : Eti_Error; - Ptr : chars_ptr; + Res : Eti_Error; + Ptr : chars_ptr; begin - Ptr := Descname (Itm); - if Ptr /= Null_Ptr then - Interfaces.C.Strings.Free (Ptr); + Ptr := Descname (Itm); + if Ptr /= Null_Ptr then + Interfaces.C.Strings.Free (Ptr); end if; - Ptr := Itemname (Itm); - if Ptr /= Null_Ptr then - Interfaces.C.Strings.Free (Ptr); + Ptr := Itemname (Itm); + if Ptr /= Null_Ptr then + Interfaces.C.Strings.Free (Ptr); end if; - Res := Freeitem (Itm); - if Res /= E_Ok then - Eti_Exception (Res); + Res := Freeitem (Itm); + if Res /= E_Ok then + Eti_Exception (Res); end if; - Itm := Null_Item; - end Delete; + Itm := Null_Item; + end Delete; ------------------------------------------------------------------------------- - procedure Set_Value (Itm : in Item; - Value : in Boolean := True) + procedure Set_Value (Itm : Item; + Value : Boolean := True) is - function Set_Item_Val (Itm : Item; - Val : C_Int) return C_Int; - pragma Import (C, Set_Item_Val, "set_item_value"); + function Set_Item_Val (Itm : Item; + Val : C_Int) return C_Int; + pragma Import (C, Set_Item_Val, "set_item_value"); - Res : constant Eti_Error := Set_Item_Val (Itm, Boolean'Pos (Value)); + Res : constant Eti_Error := Set_Item_Val (Itm, Boolean'Pos (Value)); begin - if Res /= E_Ok then - Eti_Exception (Res); + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Set_Value; + end Set_Value; - function Value (Itm : Item) return Boolean + function Value (Itm : Item) return Boolean is - function Item_Val (Itm : Item) return C_Int; - pragma Import (C, Item_Val, "item_value"); + function Item_Val (Itm : Item) return C_Int; + pragma Import (C, Item_Val, "item_value"); begin - if Item_Val (Itm) = Curses_False then + if Item_Val (Itm) = Curses_False then return False; else return True; end if; - end Value; + end Value; ------------------------------------------------------------------------------- - function Visible (Itm : Item) return Boolean + function Visible (Itm : Item) return Boolean is - function Item_Vis (Itm : Item) return C_Int; - pragma Import (C, Item_Vis, "item_visible"); + function Item_Vis (Itm : Item) return C_Int; + pragma Import (C, Item_Vis, "item_visible"); begin - if Item_Vis (Itm) = Curses_False then + if Item_Vis (Itm) = Curses_False then return False; else return True; end if; - end Visible; + end Visible; ------------------------------------------------------------------------------- - procedure Set_Options (Itm : in Item; - Options : in Item_Option_Set) + procedure Set_Options (Itm : Item; + Options : Item_Option_Set) is - function Set_Item_Opts (Itm : Item; - Opt : C_Int) return C_Int; - pragma Import (C, Set_Item_Opts, "set_item_opts"); + function Set_Item_Opts (Itm : Item; + Opt : C_Int) return C_Int; + pragma Import (C, Set_Item_Opts, "set_item_opts"); - Opt : C_Int := IOS_2_CInt (Options); - Res : Eti_Error; + Opt : constant C_Int := IOS_2_CInt (Options); + Res : Eti_Error; begin - Res := Set_Item_Opts (Itm, Opt); - if Res /= E_Ok then - Eti_Exception (Res); + Res := Set_Item_Opts (Itm, Opt); + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Set_Options; + end Set_Options; - procedure Switch_Options (Itm : in Item; - Options : in Item_Option_Set; - On : Boolean := True) + procedure Switch_Options (Itm : Item; + Options : Item_Option_Set; + On : Boolean := True) is - function Item_Opts_On (Itm : Item; - Opt : C_Int) return C_Int; - pragma Import (C, Item_Opts_On, "item_opts_on"); - function Item_Opts_Off (Itm : Item; - Opt : C_Int) return C_Int; - pragma Import (C, Item_Opts_Off, "item_opts_off"); + function Item_Opts_On (Itm : Item; + Opt : C_Int) return C_Int; + pragma Import (C, Item_Opts_On, "item_opts_on"); + function Item_Opts_Off (Itm : Item; + Opt : C_Int) return C_Int; + pragma Import (C, Item_Opts_Off, "item_opts_off"); - Opt : C_Int := IOS_2_CInt (Options); - Err : Eti_Error; + Opt : constant C_Int := IOS_2_CInt (Options); + Err : Eti_Error; begin - if On then - Err := Item_Opts_On (Itm, Opt); + if On then + Err := Item_Opts_On (Itm, Opt); else - Err := Item_Opts_Off (Itm, Opt); + Err := Item_Opts_Off (Itm, Opt); end if; - if Err /= E_Ok then - Eti_Exception (Err); + if Err /= E_Ok then + Eti_Exception (Err); end if; - end Switch_Options; + end Switch_Options; - procedure Get_Options (Itm : in Item; - Options : out Item_Option_Set) + procedure Get_Options (Itm : Item; + Options : out Item_Option_Set) is - function Item_Opts (Itm : Item) return C_Int; - pragma Import (C, Item_Opts, "item_opts"); + function Item_Opts (Itm : Item) return C_Int; + pragma Import (C, Item_Opts, "item_opts"); - Res : C_Int := Item_Opts (Itm); + Res : constant C_Int := Item_Opts (Itm); begin - Options := CInt_2_IOS (Res); - end Get_Options; + Options := CInt_2_IOS (Res); + end Get_Options; - function Get_Options (Itm : Item := Null_Item) return Item_Option_Set + function Get_Options (Itm : Item := Null_Item) return Item_Option_Set is - Ios : Item_Option_Set; + Ios : Item_Option_Set; begin - Get_Options (Itm, Ios); - return Ios; - end Get_Options; + Get_Options (Itm, Ios); + return Ios; + end Get_Options; ------------------------------------------------------------------------------- - procedure Name (Itm : in Item; - Name : out String) + procedure Name (Itm : Item; + Name : out String) is - function Itemname (Itm : Item) return chars_ptr; - pragma Import (C, Itemname, "item_name"); + function Itemname (Itm : Item) return chars_ptr; + pragma Import (C, Itemname, "item_name"); begin - Fill_String (Itemname (Itm), Name); - end Name; + Fill_String (Itemname (Itm), Name); + end Name; - function Name (Itm : in Item) return String + function Name (Itm : Item) return String is - function Itemname (Itm : Item) return chars_ptr; - pragma Import (C, Itemname, "item_name"); + function Itemname (Itm : Item) return chars_ptr; + pragma Import (C, Itemname, "item_name"); begin - return Fill_String (Itemname (Itm)); - end Name; + return Fill_String (Itemname (Itm)); + end Name; - procedure Description (Itm : in Item; - Description : out String) + procedure Description (Itm : Item; + Description : out String) is - function Descname (Itm : Item) return chars_ptr; - pragma Import (C, Descname, "item_description"); + function Descname (Itm : Item) return chars_ptr; + pragma Import (C, Descname, "item_description"); begin - Fill_String (Descname (Itm), Description); - end Description; + Fill_String (Descname (Itm), Description); + end Description; - function Description (Itm : in Item) return String + function Description (Itm : Item) return String is - function Descname (Itm : Item) return chars_ptr; - pragma Import (C, Descname, "item_description"); + function Descname (Itm : Item) return chars_ptr; + pragma Import (C, Descname, "item_description"); begin - return Fill_String (Descname (Itm)); - end Description; + return Fill_String (Descname (Itm)); + end Description; ------------------------------------------------------------------------------- - procedure Set_Current (Men : in Menu; - Itm : in Item) + procedure Set_Current (Men : Menu; + Itm : Item) is - function Set_Curr_Item (Men : Menu; - Itm : Item) return C_Int; - pragma Import (C, Set_Curr_Item, "set_current_item"); + function Set_Curr_Item (Men : Menu; + Itm : Item) return C_Int; + pragma Import (C, Set_Curr_Item, "set_current_item"); - Res : constant Eti_Error := Set_Curr_Item (Men, Itm); + Res : constant Eti_Error := Set_Curr_Item (Men, Itm); begin - if Res /= E_Ok then - Eti_Exception (Res); + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Set_Current; + end Set_Current; - function Current (Men : Menu) return Item + function Current (Men : Menu) return Item is - function Curr_Item (Men : Menu) return Item; - pragma Import (C, Curr_Item, "current_item"); + function Curr_Item (Men : Menu) return Item; + pragma Import (C, Curr_Item, "current_item"); - Res : constant Item := Curr_Item (Men); + Res : constant Item := Curr_Item (Men); begin - if Res = Null_Item then - raise Menu_Exception; + if Res = Null_Item then + raise Menu_Exception; end if; - return Res; - end Current; + return Res; + end Current; - procedure Set_Top_Row (Men : in Menu; - Line : in Line_Position) + procedure Set_Top_Row (Men : Menu; + Line : Line_Position) is - function Set_Toprow (Men : Menu; - Line : C_Int) return C_Int; - pragma Import (C, Set_Toprow, "set_top_row"); + function Set_Toprow (Men : Menu; + Line : C_Int) return C_Int; + pragma Import (C, Set_Toprow, "set_top_row"); - Res : constant Eti_Error := Set_Toprow (Men, C_Int (Line)); + Res : constant Eti_Error := Set_Toprow (Men, C_Int (Line)); begin - if Res /= E_Ok then - Eti_Exception (Res); + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Set_Top_Row; + end Set_Top_Row; - function Top_Row (Men : Menu) return Line_Position + function Top_Row (Men : Menu) return Line_Position is - function Toprow (Men : Menu) return C_Int; - pragma Import (C, Toprow, "top_row"); + function Toprow (Men : Menu) return C_Int; + pragma Import (C, Toprow, "top_row"); - Res : constant C_Int := Toprow (Men); + Res : constant C_Int := Toprow (Men); begin - if Res = Curses_Err then - raise Menu_Exception; + if Res = Curses_Err then + raise Menu_Exception; end if; - return Line_Position (Res); - end Top_Row; + return Line_Position (Res); + end Top_Row; - function Get_Index (Itm : Item) return Positive + function Get_Index (Itm : Item) return Positive is - function Get_Itemindex (Itm : Item) return C_Int; - pragma Import (C, Get_Itemindex, "item_index"); + function Get_Itemindex (Itm : Item) return C_Int; + pragma Import (C, Get_Itemindex, "item_index"); - Res : constant C_Int := Get_Itemindex (Itm); + Res : constant C_Int := Get_Itemindex (Itm); begin - if Res = Curses_Err then - raise Menu_Exception; + if Res = Curses_Err then + raise Menu_Exception; end if; - return Positive (Natural (Res) + Positive'First); - end Get_Index; + return Positive (Natural (Res) + Positive'First); + end Get_Index; ------------------------------------------------------------------------------- - procedure Post (Men : in Menu; - Post : in Boolean := True) + procedure Post (Men : Menu; + Post : Boolean := True) is - function M_Post (Men : Menu) return C_Int; - pragma Import (C, M_Post, "post_menu"); - function M_Unpost (Men : Menu) return C_Int; - pragma Import (C, M_Unpost, "unpost_menu"); + function M_Post (Men : Menu) return C_Int; + pragma Import (C, M_Post, "post_menu"); + function M_Unpost (Men : Menu) return C_Int; + pragma Import (C, M_Unpost, "unpost_menu"); - Res : Eti_Error; + Res : Eti_Error; begin - if Post then - Res := M_Post (Men); + if Post then + Res := M_Post (Men); else - Res := M_Unpost (Men); + Res := M_Unpost (Men); end if; - if Res /= E_Ok then - Eti_Exception (Res); + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Post; + end Post; ------------------------------------------------------------------------------- - procedure Set_Options (Men : in Menu; - Options : in Menu_Option_Set) + procedure Set_Options (Men : Menu; + Options : Menu_Option_Set) is - function Set_Menu_Opts (Men : Menu; - Opt : C_Int) return C_Int; - pragma Import (C, Set_Menu_Opts, "set_menu_opts"); + function Set_Menu_Opts (Men : Menu; + Opt : C_Int) return C_Int; + pragma Import (C, Set_Menu_Opts, "set_menu_opts"); - Opt : C_Int := MOS_2_CInt (Options); - Res : Eti_Error; + Opt : constant C_Int := MOS_2_CInt (Options); + Res : Eti_Error; begin - Res := Set_Menu_Opts (Men, Opt); - if Res /= E_Ok then - Eti_Exception (Res); + Res := Set_Menu_Opts (Men, Opt); + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Set_Options; + end Set_Options; - procedure Switch_Options (Men : in Menu; - Options : in Menu_Option_Set; - On : in Boolean := True) + procedure Switch_Options (Men : Menu; + Options : Menu_Option_Set; + On : Boolean := True) is - function Menu_Opts_On (Men : Menu; - Opt : C_Int) return C_Int; - pragma Import (C, Menu_Opts_On, "menu_opts_on"); - function Menu_Opts_Off (Men : Menu; - Opt : C_Int) return C_Int; - pragma Import (C, Menu_Opts_Off, "menu_opts_off"); + function Menu_Opts_On (Men : Menu; + Opt : C_Int) return C_Int; + pragma Import (C, Menu_Opts_On, "menu_opts_on"); + function Menu_Opts_Off (Men : Menu; + Opt : C_Int) return C_Int; + pragma Import (C, Menu_Opts_Off, "menu_opts_off"); - Opt : C_Int := MOS_2_CInt (Options); - Err : Eti_Error; + Opt : constant C_Int := MOS_2_CInt (Options); + Err : Eti_Error; begin - if On then - Err := Menu_Opts_On (Men, Opt); + if On then + Err := Menu_Opts_On (Men, Opt); else - Err := Menu_Opts_Off (Men, Opt); + Err := Menu_Opts_Off (Men, Opt); end if; - if Err /= E_Ok then - Eti_Exception (Err); + if Err /= E_Ok then + Eti_Exception (Err); end if; - end Switch_Options; + end Switch_Options; - procedure Get_Options (Men : in Menu; - Options : out Menu_Option_Set) + procedure Get_Options (Men : Menu; + Options : out Menu_Option_Set) is - function Menu_Opts (Men : Menu) return C_Int; - pragma Import (C, Menu_Opts, "menu_opts"); + function Menu_Opts (Men : Menu) return C_Int; + pragma Import (C, Menu_Opts, "menu_opts"); - Res : C_Int := Menu_Opts (Men); + Res : constant C_Int := Menu_Opts (Men); begin - Options := CInt_2_MOS (Res); - end Get_Options; + Options := CInt_2_MOS (Res); + end Get_Options; - function Get_Options (Men : Menu := Null_Menu) return Menu_Option_Set + function Get_Options (Men : Menu := Null_Menu) return Menu_Option_Set is - Mos : Menu_Option_Set; + Mos : Menu_Option_Set; begin - Get_Options (Men, Mos); - return Mos; - end Get_Options; + Get_Options (Men, Mos); + return Mos; + end Get_Options; ------------------------------------------------------------------------------- - procedure Set_Window (Men : in Menu; - Win : in Window) + procedure Set_Window (Men : Menu; + Win : Window) is - function Set_Menu_Win (Men : Menu; - Win : Window) return C_Int; - pragma Import (C, Set_Menu_Win, "set_menu_win"); + function Set_Menu_Win (Men : Menu; + Win : Window) return C_Int; + pragma Import (C, Set_Menu_Win, "set_menu_win"); - Res : constant Eti_Error := Set_Menu_Win (Men, Win); + Res : constant Eti_Error := Set_Menu_Win (Men, Win); begin - if Res /= E_Ok then - Eti_Exception (Res); + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Set_Window; + end Set_Window; - function Get_Window (Men : Menu) return Window + function Get_Window (Men : Menu) return Window is - function Menu_Win (Men : Menu) return Window; - pragma Import (C, Menu_Win, "menu_win"); + function Menu_Win (Men : Menu) return Window; + pragma Import (C, Menu_Win, "menu_win"); - W : constant Window := Menu_Win (Men); + W : constant Window := Menu_Win (Men); begin - return W; - end Get_Window; + return W; + end Get_Window; - procedure Set_Sub_Window (Men : in Menu; - Win : in Window) + procedure Set_Sub_Window (Men : Menu; + Win : Window) is - function Set_Menu_Sub (Men : Menu; - Win : Window) return C_Int; - pragma Import (C, Set_Menu_Sub, "set_menu_sub"); + function Set_Menu_Sub (Men : Menu; + Win : Window) return C_Int; + pragma Import (C, Set_Menu_Sub, "set_menu_sub"); - Res : constant Eti_Error := Set_Menu_Sub (Men, Win); + Res : constant Eti_Error := Set_Menu_Sub (Men, Win); begin - if Res /= E_Ok then - Eti_Exception (Res); + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Set_Sub_Window; + end Set_Sub_Window; - function Get_Sub_Window (Men : Menu) return Window + function Get_Sub_Window (Men : Menu) return Window is - function Menu_Sub (Men : Menu) return Window; - pragma Import (C, Menu_Sub, "menu_sub"); + function Menu_Sub (Men : Menu) return Window; + pragma Import (C, Menu_Sub, "menu_sub"); - W : constant Window := Menu_Sub (Men); + W : constant Window := Menu_Sub (Men); begin - return W; - end Get_Sub_Window; + return W; + end Get_Sub_Window; - procedure Scale (Men : in Menu; - Lines : out Line_Count; - Columns : out Column_Count) + procedure Scale (Men : Menu; + Lines : out Line_Count; + Columns : out Column_Count) is - type C_Int_Access is access all C_Int; - function M_Scale (Men : Menu; - Yp, Xp : C_Int_Access) return C_Int; - pragma Import (C, M_Scale, "scale_menu"); + type C_Int_Access is access all C_Int; + function M_Scale (Men : Menu; + Yp, Xp : C_Int_Access) return C_Int; + pragma Import (C, M_Scale, "scale_menu"); - X, Y : aliased C_Int; - Res : constant Eti_Error := M_Scale (Men, Y'Access, X'Access); + X, Y : aliased C_Int; + Res : constant Eti_Error := M_Scale (Men, Y'Access, X'Access); begin - if Res /= E_Ok then - Eti_Exception (Res); + if Res /= E_Ok then + Eti_Exception (Res); end if; - Lines := Line_Count (Y); - Columns := Column_Count (X); - end Scale; + Lines := Line_Count (Y); + Columns := Column_Count (X); + end Scale; ------------------------------------------------------------------------------- - procedure Position_Cursor (Men : Menu) + procedure Position_Cursor (Men : Menu) is - function Pos_Menu_Cursor (Men : Menu) return C_Int; - pragma Import (C, Pos_Menu_Cursor, "pos_menu_cursor"); + function Pos_Menu_Cursor (Men : Menu) return C_Int; + pragma Import (C, Pos_Menu_Cursor, "pos_menu_cursor"); - Res : constant Eti_Error := Pos_Menu_Cursor (Men); + Res : constant Eti_Error := Pos_Menu_Cursor (Men); begin - if Res /= E_Ok then - Eti_Exception (Res); + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Position_Cursor; + end Position_Cursor; ------------------------------------------------------------------------------- - procedure Set_Mark (Men : in Menu; - Mark : in String) - is - type Char_Ptr is access all Interfaces.C.char; - function Set_Mark (Men : Menu; - Mark : Char_Ptr) return C_Int; - pragma Import (C, Set_Mark, "set_menu_mark"); - - Txt : char_array (0 .. Mark'Length); - Len : size_t; - Res : Eti_Error; - begin - To_C (Mark, Txt, Len); - Res := Set_Mark (Men, Txt (Txt'First)'Access); - if Res /= E_Ok then - Eti_Exception (Res); + procedure Set_Mark (Men : Menu; + Mark : String) + is + type Char_Ptr is access all Interfaces.C.char; + function Set_Mark (Men : Menu; + Mark : Char_Ptr) return C_Int; + pragma Import (C, Set_Mark, "set_menu_mark"); + + Txt : char_array (0 .. Mark'Length); + Len : size_t; + Res : Eti_Error; + begin + To_C (Mark, Txt, Len); + Res := Set_Mark (Men, Txt (Txt'First)'Access); + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Set_Mark; + end Set_Mark; - procedure Mark (Men : in Menu; - Mark : out String) + procedure Mark (Men : Menu; + Mark : out String) is - function Get_Menu_Mark (Men : Menu) return chars_ptr; - pragma Import (C, Get_Menu_Mark, "menu_mark"); + function Get_Menu_Mark (Men : Menu) return chars_ptr; + pragma Import (C, Get_Menu_Mark, "menu_mark"); begin - Fill_String (Get_Menu_Mark (Men), Mark); - end Mark; + Fill_String (Get_Menu_Mark (Men), Mark); + end Mark; - function Mark (Men : Menu) return String + function Mark (Men : Menu) return String is - function Get_Menu_Mark (Men : Menu) return chars_ptr; - pragma Import (C, Get_Menu_Mark, "menu_mark"); + function Get_Menu_Mark (Men : Menu) return chars_ptr; + pragma Import (C, Get_Menu_Mark, "menu_mark"); begin - return Fill_String (Get_Menu_Mark (Men)); - end Mark; + return Fill_String (Get_Menu_Mark (Men)); + end Mark; ------------------------------------------------------------------------------- - procedure Set_Foreground - (Men : in Menu; - Fore : in Character_Attribute_Set := Normal_Video; - Color : in Color_Pair := Color_Pair'First) - is - function Set_Menu_Fore (Men : Menu; - Attr : C_Chtype) return C_Int; - pragma Import (C, Set_Menu_Fore, "set_menu_fore"); - - Ch : constant Attributed_Character := (Ch => Character'First, - Color => Color, - Attr => Fore); - Res : constant Eti_Error := Set_Menu_Fore (Men, AttrChar_To_Chtype (Ch)); - begin - if Res /= E_Ok then - Eti_Exception (Res); + procedure Set_Foreground + (Men : Menu; + Fore : Character_Attribute_Set := Normal_Video; + Color : Color_Pair := Color_Pair'First) + is + function Set_Menu_Fore (Men : Menu; + Attr : C_Chtype) return C_Int; + pragma Import (C, Set_Menu_Fore, "set_menu_fore"); + + Ch : constant Attributed_Character := (Ch => Character'First, + Color => Color, + Attr => Fore); + Res : constant Eti_Error := Set_Menu_Fore (Men, AttrChar_To_Chtype (Ch)); + begin + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Set_Foreground; + end Set_Foreground; - procedure Foreground (Men : in Menu; - Fore : out Character_Attribute_Set) + procedure Foreground (Men : Menu; + Fore : out Character_Attribute_Set) is - function Menu_Fore (Men : Menu) return C_Chtype; - pragma Import (C, Menu_Fore, "menu_fore"); + function Menu_Fore (Men : Menu) return C_Chtype; + pragma Import (C, Menu_Fore, "menu_fore"); begin - Fore := Chtype_To_AttrChar (Menu_Fore (Men)).Attr; - end Foreground; + Fore := Chtype_To_AttrChar (Menu_Fore (Men)).Attr; + end Foreground; - procedure Foreground (Men : in Menu; - Fore : out Character_Attribute_Set; - Color : out Color_Pair) + procedure Foreground (Men : Menu; + Fore : out Character_Attribute_Set; + Color : out Color_Pair) is - function Menu_Fore (Men : Menu) return C_Chtype; - pragma Import (C, Menu_Fore, "menu_fore"); + function Menu_Fore (Men : Menu) return C_Chtype; + pragma Import (C, Menu_Fore, "menu_fore"); begin - Fore := Chtype_To_AttrChar (Menu_Fore (Men)).Attr; - Color := Chtype_To_AttrChar (Menu_Fore (Men)).Color; - end Foreground; + Fore := Chtype_To_AttrChar (Menu_Fore (Men)).Attr; + Color := Chtype_To_AttrChar (Menu_Fore (Men)).Color; + end Foreground; - procedure Set_Background - (Men : in Menu; - Back : in Character_Attribute_Set := Normal_Video; - Color : in Color_Pair := Color_Pair'First) + procedure Set_Background + (Men : Menu; + Back : Character_Attribute_Set := Normal_Video; + Color : Color_Pair := Color_Pair'First) is - function Set_Menu_Back (Men : Menu; - Attr : C_Chtype) return C_Int; - pragma Import (C, Set_Menu_Back, "set_menu_back"); + function Set_Menu_Back (Men : Menu; + Attr : C_Chtype) return C_Int; + pragma Import (C, Set_Menu_Back, "set_menu_back"); - Ch : constant Attributed_Character := (Ch => Character'First, - Color => Color, - Attr => Back); - Res : constant Eti_Error := Set_Menu_Back (Men, AttrChar_To_Chtype (Ch)); + Ch : constant Attributed_Character := (Ch => Character'First, + Color => Color, + Attr => Back); + Res : constant Eti_Error := Set_Menu_Back (Men, AttrChar_To_Chtype (Ch)); begin - if Res /= E_Ok then - Eti_Exception (Res); + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Set_Background; + end Set_Background; - procedure Background (Men : in Menu; - Back : out Character_Attribute_Set) + procedure Background (Men : Menu; + Back : out Character_Attribute_Set) is - function Menu_Back (Men : Menu) return C_Chtype; - pragma Import (C, Menu_Back, "menu_back"); + function Menu_Back (Men : Menu) return C_Chtype; + pragma Import (C, Menu_Back, "menu_back"); begin - Back := Chtype_To_AttrChar (Menu_Back (Men)).Attr; - end Background; + Back := Chtype_To_AttrChar (Menu_Back (Men)).Attr; + end Background; - procedure Background (Men : in Menu; - Back : out Character_Attribute_Set; - Color : out Color_Pair) + procedure Background (Men : Menu; + Back : out Character_Attribute_Set; + Color : out Color_Pair) is - function Menu_Back (Men : Menu) return C_Chtype; - pragma Import (C, Menu_Back, "menu_back"); + function Menu_Back (Men : Menu) return C_Chtype; + pragma Import (C, Menu_Back, "menu_back"); begin - Back := Chtype_To_AttrChar (Menu_Back (Men)).Attr; - Color := Chtype_To_AttrChar (Menu_Back (Men)).Color; - end Background; + Back := Chtype_To_AttrChar (Menu_Back (Men)).Attr; + Color := Chtype_To_AttrChar (Menu_Back (Men)).Color; + end Background; - procedure Set_Grey (Men : in Menu; - Grey : in Character_Attribute_Set := Normal_Video; - Color : in Color_Pair := Color_Pair'First) + procedure Set_Grey (Men : Menu; + Grey : Character_Attribute_Set := Normal_Video; + Color : Color_Pair := Color_Pair'First) is - function Set_Menu_Grey (Men : Menu; - Attr : C_Chtype) return C_Int; - pragma Import (C, Set_Menu_Grey, "set_menu_grey"); + function Set_Menu_Grey (Men : Menu; + Attr : C_Chtype) return C_Int; + pragma Import (C, Set_Menu_Grey, "set_menu_grey"); - Ch : constant Attributed_Character := (Ch => Character'First, - Color => Color, - Attr => Grey); + Ch : constant Attributed_Character := (Ch => Character'First, + Color => Color, + Attr => Grey); - Res : constant Eti_Error := Set_Menu_Grey (Men, AttrChar_To_Chtype (Ch)); + Res : constant Eti_Error := Set_Menu_Grey (Men, AttrChar_To_Chtype (Ch)); begin - if Res /= E_Ok then - Eti_Exception (Res); + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Set_Grey; + end Set_Grey; - procedure Grey (Men : in Menu; - Grey : out Character_Attribute_Set) + procedure Grey (Men : Menu; + Grey : out Character_Attribute_Set) is - function Menu_Grey (Men : Menu) return C_Chtype; - pragma Import (C, Menu_Grey, "menu_grey"); + function Menu_Grey (Men : Menu) return C_Chtype; + pragma Import (C, Menu_Grey, "menu_grey"); begin - Grey := Chtype_To_AttrChar (Menu_Grey (Men)).Attr; - end Grey; + Grey := Chtype_To_AttrChar (Menu_Grey (Men)).Attr; + end Grey; - procedure Grey (Men : in Menu; - Grey : out Character_Attribute_Set; - Color : out Color_Pair) + procedure Grey (Men : Menu; + Grey : out Character_Attribute_Set; + Color : out Color_Pair) is - function Menu_Grey (Men : Menu) return C_Chtype; - pragma Import (C, Menu_Grey, "menu_grey"); + function Menu_Grey (Men : Menu) return C_Chtype; + pragma Import (C, Menu_Grey, "menu_grey"); begin - Grey := Chtype_To_AttrChar (Menu_Grey (Men)).Attr; - Color := Chtype_To_AttrChar (Menu_Grey (Men)).Color; - end Grey; + Grey := Chtype_To_AttrChar (Menu_Grey (Men)).Attr; + Color := Chtype_To_AttrChar (Menu_Grey (Men)).Color; + end Grey; - procedure Set_Pad_Character (Men : in Menu; - Pad : in Character := Space) + procedure Set_Pad_Character (Men : Menu; + Pad : Character := Space) is - function Set_Menu_Pad (Men : Menu; - Ch : C_Int) return C_Int; - pragma Import (C, Set_Menu_Pad, "set_menu_pad"); + function Set_Menu_Pad (Men : Menu; + Ch : C_Int) return C_Int; + pragma Import (C, Set_Menu_Pad, "set_menu_pad"); - Res : constant Eti_Error := Set_Menu_Pad (Men, - C_Int (Character'Pos (Pad))); + Res : constant Eti_Error := Set_Menu_Pad (Men, + C_Int (Character'Pos (Pad))); begin - if Res /= E_Ok then - Eti_Exception (Res); + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Set_Pad_Character; + end Set_Pad_Character; - procedure Pad_Character (Men : in Menu; - Pad : out Character) + procedure Pad_Character (Men : Menu; + Pad : out Character) is - function Menu_Pad (Men : Menu) return C_Int; - pragma Import (C, Menu_Pad, "menu_pad"); + function Menu_Pad (Men : Menu) return C_Int; + pragma Import (C, Menu_Pad, "menu_pad"); begin - Pad := Character'Val (Menu_Pad (Men)); - end Pad_Character; + Pad := Character'Val (Menu_Pad (Men)); + end Pad_Character; ------------------------------------------------------------------------------- - procedure Set_Spacing (Men : in Menu; - Descr : in Column_Position := 0; - Row : in Line_Position := 0; - Col : in Column_Position := 0) - is - function Set_Spacing (Men : Menu; - D, R, C : C_Int) return C_Int; - pragma Import (C, Set_Spacing, "set_menu_spacing"); - - Res : constant Eti_Error := Set_Spacing (Men, - C_Int (Descr), - C_Int (Row), - C_Int (Col)); - begin - if Res /= E_Ok then - Eti_Exception (Res); + procedure Set_Spacing (Men : Menu; + Descr : Column_Position := 0; + Row : Line_Position := 0; + Col : Column_Position := 0) + is + function Set_Spacing (Men : Menu; + D, R, C : C_Int) return C_Int; + pragma Import (C, Set_Spacing, "set_menu_spacing"); + + Res : constant Eti_Error := Set_Spacing (Men, + C_Int (Descr), + C_Int (Row), + C_Int (Col)); + begin + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Set_Spacing; - - procedure Spacing (Men : in Menu; - Descr : out Column_Position; - Row : out Line_Position; - Col : out Column_Position) - is - type C_Int_Access is access all C_Int; - function Get_Spacing (Men : Menu; - D, R, C : C_Int_Access) return C_Int; - pragma Import (C, Get_Spacing, "menu_spacing"); - - D, R, C : aliased C_Int; - Res : constant Eti_Error := Get_Spacing (Men, - D'Access, - R'Access, - C'Access); - begin - if Res /= E_Ok then - Eti_Exception (Res); + end Set_Spacing; + + procedure Spacing (Men : Menu; + Descr : out Column_Position; + Row : out Line_Position; + Col : out Column_Position) + is + type C_Int_Access is access all C_Int; + function Get_Spacing (Men : Menu; + D, R, C : C_Int_Access) return C_Int; + pragma Import (C, Get_Spacing, "menu_spacing"); + + D, R, C : aliased C_Int; + Res : constant Eti_Error := Get_Spacing (Men, + D'Access, + R'Access, + C'Access); + begin + if Res /= E_Ok then + Eti_Exception (Res); else - Descr := Column_Position (D); - Row := Line_Position (R); - Col := Column_Position (C); + Descr := Column_Position (D); + Row := Line_Position (R); + Col := Column_Position (C); end if; - end Spacing; + end Spacing; ------------------------------------------------------------------------------- - function Set_Pattern (Men : Menu; - Text : String) return Boolean - is - type Char_Ptr is access all Interfaces.C.char; - function Set_Pattern (Men : Menu; - Pattern : Char_Ptr) return C_Int; - pragma Import (C, Set_Pattern, "set_menu_pattern"); - - S : char_array (0 .. Text'Length); - L : size_t; - Res : Eti_Error; - begin - To_C (Text, S, L); - Res := Set_Pattern (Men, S (S'First)'Access); - case Res is - when E_No_Match => return False; - when E_Ok => return True; + function Set_Pattern (Men : Menu; + Text : String) return Boolean + is + type Char_Ptr is access all Interfaces.C.char; + function Set_Pattern (Men : Menu; + Pattern : Char_Ptr) return C_Int; + pragma Import (C, Set_Pattern, "set_menu_pattern"); + + S : char_array (0 .. Text'Length); + L : size_t; + Res : Eti_Error; + begin + To_C (Text, S, L); + Res := Set_Pattern (Men, S (S'First)'Access); + case Res is + when E_No_Match => return False; + when E_Ok => return True; when others => - Eti_Exception (Res); + Eti_Exception (Res); return False; end case; - end Set_Pattern; + end Set_Pattern; - procedure Pattern (Men : in Menu; - Text : out String) + procedure Pattern (Men : Menu; + Text : out String) is - function Get_Pattern (Men : Menu) return chars_ptr; - pragma Import (C, Get_Pattern, "menu_pattern"); + function Get_Pattern (Men : Menu) return chars_ptr; + pragma Import (C, Get_Pattern, "menu_pattern"); begin - Fill_String (Get_Pattern (Men), Text); - end Pattern; + Fill_String (Get_Pattern (Men), Text); + end Pattern; ------------------------------------------------------------------------------- - procedure Set_Format (Men : in Menu; - Lines : in Line_Count; - Columns : in Column_Count) + procedure Set_Format (Men : Menu; + Lines : Line_Count; + Columns : Column_Count) is - function Set_Menu_Fmt (Men : Menu; - Lin : C_Int; - Col : C_Int) return C_Int; - pragma Import (C, Set_Menu_Fmt, "set_menu_format"); + function Set_Menu_Fmt (Men : Menu; + Lin : C_Int; + Col : C_Int) return C_Int; + pragma Import (C, Set_Menu_Fmt, "set_menu_format"); - Res : constant Eti_Error := Set_Menu_Fmt (Men, - C_Int (Lines), - C_Int (Columns)); + Res : constant Eti_Error := Set_Menu_Fmt (Men, + C_Int (Lines), + C_Int (Columns)); begin - if Res /= E_Ok then - Eti_Exception (Res); + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Set_Format; + end Set_Format; - procedure Format (Men : in Menu; - Lines : out Line_Count; - Columns : out Column_Count) + procedure Format (Men : Menu; + Lines : out Line_Count; + Columns : out Column_Count) is - type C_Int_Access is access all C_Int; - function Menu_Fmt (Men : Menu; - Y, X : C_Int_Access) return C_Int; - pragma Import (C, Menu_Fmt, "menu_format"); + type C_Int_Access is access all C_Int; + function Menu_Fmt (Men : Menu; + Y, X : C_Int_Access) return C_Int; + pragma Import (C, Menu_Fmt, "menu_format"); - L, C : aliased C_Int; - Res : constant Eti_Error := Menu_Fmt (Men, L'Access, C'Access); + L, C : aliased C_Int; + Res : constant Eti_Error := Menu_Fmt (Men, L'Access, C'Access); begin - if Res /= E_Ok then - Eti_Exception (Res); + if Res /= E_Ok then + Eti_Exception (Res); else - Lines := Line_Count (L); - Columns := Column_Count (C); + Lines := Line_Count (L); + Columns := Column_Count (C); end if; - end Format; + end Format; ------------------------------------------------------------------------------- - procedure Set_Item_Init_Hook (Men : in Menu; - Proc : in Menu_Hook_Function) + procedure Set_Item_Init_Hook (Men : Menu; + Proc : Menu_Hook_Function) is - function Set_Item_Init (Men : Menu; - Proc : Menu_Hook_Function) return C_Int; - pragma Import (C, Set_Item_Init, "set_item_init"); + function Set_Item_Init (Men : Menu; + Proc : Menu_Hook_Function) return C_Int; + pragma Import (C, Set_Item_Init, "set_item_init"); - Res : constant Eti_Error := Set_Item_Init (Men, Proc); + Res : constant Eti_Error := Set_Item_Init (Men, Proc); begin - if Res /= E_Ok then - Eti_Exception (Res); + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Set_Item_Init_Hook; + end Set_Item_Init_Hook; - procedure Set_Item_Term_Hook (Men : in Menu; - Proc : in Menu_Hook_Function) + procedure Set_Item_Term_Hook (Men : Menu; + Proc : Menu_Hook_Function) is - function Set_Item_Term (Men : Menu; - Proc : Menu_Hook_Function) return C_Int; - pragma Import (C, Set_Item_Term, "set_item_term"); + function Set_Item_Term (Men : Menu; + Proc : Menu_Hook_Function) return C_Int; + pragma Import (C, Set_Item_Term, "set_item_term"); - Res : constant Eti_Error := Set_Item_Term (Men, Proc); + Res : constant Eti_Error := Set_Item_Term (Men, Proc); begin - if Res /= E_Ok then - Eti_Exception (Res); + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Set_Item_Term_Hook; + end Set_Item_Term_Hook; - procedure Set_Menu_Init_Hook (Men : in Menu; - Proc : in Menu_Hook_Function) + procedure Set_Menu_Init_Hook (Men : Menu; + Proc : Menu_Hook_Function) is - function Set_Menu_Init (Men : Menu; - Proc : Menu_Hook_Function) return C_Int; - pragma Import (C, Set_Menu_Init, "set_menu_init"); + function Set_Menu_Init (Men : Menu; + Proc : Menu_Hook_Function) return C_Int; + pragma Import (C, Set_Menu_Init, "set_menu_init"); - Res : constant Eti_Error := Set_Menu_Init (Men, Proc); + Res : constant Eti_Error := Set_Menu_Init (Men, Proc); begin - if Res /= E_Ok then - Eti_Exception (Res); + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Set_Menu_Init_Hook; + end Set_Menu_Init_Hook; - procedure Set_Menu_Term_Hook (Men : in Menu; - Proc : in Menu_Hook_Function) + procedure Set_Menu_Term_Hook (Men : Menu; + Proc : Menu_Hook_Function) is - function Set_Menu_Term (Men : Menu; - Proc : Menu_Hook_Function) return C_Int; - pragma Import (C, Set_Menu_Term, "set_menu_term"); + function Set_Menu_Term (Men : Menu; + Proc : Menu_Hook_Function) return C_Int; + pragma Import (C, Set_Menu_Term, "set_menu_term"); - Res : constant Eti_Error := Set_Menu_Term (Men, Proc); + Res : constant Eti_Error := Set_Menu_Term (Men, Proc); begin - if Res /= E_Ok then - Eti_Exception (Res); + if Res /= E_Ok then + Eti_Exception (Res); end if; - end Set_Menu_Term_Hook; + end Set_Menu_Term_Hook; - function Get_Item_Init_Hook (Men : Menu) return Menu_Hook_Function + function Get_Item_Init_Hook (Men : Menu) return Menu_Hook_Function is - function Item_Init (Men : Menu) return Menu_Hook_Function; - pragma Import (C, Item_Init, "item_init"); + function Item_Init (Men : Menu) return Menu_Hook_Function; + pragma Import (C, Item_Init, "item_init"); begin - return Item_Init (Men); - end Get_Item_Init_Hook; + return Item_Init (Men); + end Get_Item_Init_Hook; - function Get_Item_Term_Hook (Men : Menu) return Menu_Hook_Function + function Get_Item_Term_Hook (Men : Menu) return Menu_Hook_Function is - function Item_Term (Men : Menu) return Menu_Hook_Function; - pragma Import (C, Item_Term, "item_term"); + function Item_Term (Men : Menu) return Menu_Hook_Function; + pragma Import (C, Item_Term, "item_term"); begin - return Item_Term (Men); - end Get_Item_Term_Hook; + return Item_Term (Men); + end Get_Item_Term_Hook; - function Get_Menu_Init_Hook (Men : Menu) return Menu_Hook_Function + function Get_Menu_Init_Hook (Men : Menu) return Menu_Hook_Function is - function Menu_Init (Men : Menu) return Menu_Hook_Function; - pragma Import (C, Menu_Init, "menu_init"); + function Menu_Init (Men : Menu) return Menu_Hook_Function; + pragma Import (C, Menu_Init, "menu_init"); begin - return Menu_Init (Men); - end Get_Menu_Init_Hook; + return Menu_Init (Men); + end Get_Menu_Init_Hook; - function Get_Menu_Term_Hook (Men : Menu) return Menu_Hook_Function + function Get_Menu_Term_Hook (Men : Menu) return Menu_Hook_Function is - function Menu_Term (Men : Menu) return Menu_Hook_Function; - pragma Import (C, Menu_Term, "menu_term"); + function Menu_Term (Men : Menu) return Menu_Hook_Function; + pragma Import (C, Menu_Term, "menu_term"); begin - return Menu_Term (Men); - end Get_Menu_Term_Hook; + return Menu_Term (Men); + end Get_Menu_Term_Hook; ------------------------------------------------------------------------------- - procedure Redefine (Men : in Menu; - Items : in Item_Array_Access) + procedure Redefine (Men : Menu; + Items : Item_Array_Access) is - function Set_Items (Men : Menu; - Items : System.Address) return C_Int; - pragma Import (C, Set_Items, "set_menu_items"); + function Set_Items (Men : Menu; + Items : System.Address) return C_Int; + pragma Import (C, Set_Items, "set_menu_items"); - Res : Eti_Error; + Res : Eti_Error; begin - pragma Assert (Items (Items'Last) = Null_Item); - if Items (Items'Last) /= Null_Item then - raise Menu_Exception; + pragma Assert (Items (Items'Last) = Null_Item); + if Items (Items'Last) /= Null_Item then + raise Menu_Exception; else - Res := Set_Items (Men, Items.all'Address); - if Res /= E_Ok then - Eti_Exception (Res); + Res := Set_Items (Men, Items.all'Address); + if Res /= E_Ok then + Eti_Exception (Res); end if; end if; - end Redefine; + end Redefine; - function Item_Count (Men : Menu) return Natural + function Item_Count (Men : Menu) return Natural is - function Count (Men : Menu) return C_Int; - pragma Import (C, Count, "item_count"); + function Count (Men : Menu) return C_Int; + pragma Import (C, Count, "item_count"); begin - return Natural (Count (Men)); - end Item_Count; + return Natural (Count (Men)); + end Item_Count; - function Items (Men : Menu; - Index : Positive) return Item + function Items (Men : Menu; + Index : Positive) return Item is - use I_Array; + use I_Array; - function C_Mitems (Men : Menu) return Pointer; - pragma Import (C, C_Mitems, "menu_items"); + function C_Mitems (Men : Menu) return Pointer; + pragma Import (C, C_Mitems, "menu_items"); - P : Pointer := C_Mitems (Men); + P : Pointer := C_Mitems (Men); begin - if P = null or else Index not in 1 .. Item_Count (Men) then - raise Menu_Exception; + if P = null or else Index > Item_Count (Men) then + raise Menu_Exception; else - P := P + ptrdiff_t (C_Int (Index) - 1); - return P.all; + P := P + ptrdiff_t (C_Int (Index) - 1); + return P.all; end if; - end Items; + end Items; ------------------------------------------------------------------------------- - function Create (Items : Item_Array_Access) return Menu + function Create (Items : Item_Array_Access) return Menu is - function Newmenu (Items : System.Address) return Menu; - pragma Import (C, Newmenu, "new_menu"); + function Newmenu (Items : System.Address) return Menu; + pragma Import (C, Newmenu, "new_menu"); - M : Menu; + M : Menu; begin - pragma Assert (Items (Items'Last) = Null_Item); - if Items (Items'Last) /= Null_Item then - raise Menu_Exception; + pragma Assert (Items (Items'Last) = Null_Item); + if Items (Items'Last) /= Null_Item then + raise Menu_Exception; else - M := Newmenu (Items.all'Address); - if M = Null_Menu then - raise Menu_Exception; + M := Newmenu (Items.all'Address); + if M = Null_Menu then + raise Menu_Exception; end if; - return M; + return M; end if; - end Create; + end Create; - procedure Delete (Men : in out Menu) + procedure Delete (Men : in out Menu) is - function Free (Men : Menu) return C_Int; - pragma Import (C, Free, "free_menu"); + function Free (Men : Menu) return C_Int; + pragma Import (C, Free, "free_menu"); - Res : constant Eti_Error := Free (Men); + Res : constant Eti_Error := Free (Men); begin - if Res /= E_Ok then - Eti_Exception (Res); + if Res /= E_Ok then + Eti_Exception (Res); end if; - Men := Null_Menu; - end Delete; + Men := Null_Menu; + end Delete; ------------------------------------------------------------------------------ - function Driver (Men : Menu; - Key : Key_Code) return Driver_Result + function Driver (Men : Menu; + Key : Key_Code) return Driver_Result is - function Driver (Men : Menu; - Key : C_Int) return C_Int; - pragma Import (C, Driver, "menu_driver"); + function Driver (Men : Menu; + Key : C_Int) return C_Int; + pragma Import (C, Driver, "menu_driver"); - R : Eti_Error := Driver (Men, C_Int (Key)); + R : constant Eti_Error := Driver (Men, C_Int (Key)); begin - if R /= E_Ok then - case R is - when E_Unknown_Command => return Unknown_Request; - when E_No_Match => return No_Match; - when E_Request_Denied | - E_Not_Selectable => return Request_Denied; + if R /= E_Ok then + case R is + when E_Unknown_Command => return Unknown_Request; + when E_No_Match => return No_Match; + when E_Request_Denied | + E_Not_Selectable => return Request_Denied; when others => - Eti_Exception (R); + Eti_Exception (R); end case; end if; - return Menu_Ok; - end Driver; + return Menu_Ok; + end Driver; - procedure Free (IA : in out Item_Array_Access; - Free_Items : in Boolean := False) + procedure Free (IA : in out Item_Array_Access; + Free_Items : Boolean := False) is - procedure Release is new Ada.Unchecked_Deallocation - (Item_Array, Item_Array_Access); + procedure Release is new Ada.Unchecked_Deallocation + (Item_Array, Item_Array_Access); begin - if IA /= null and then Free_Items then - for I in IA'First .. (IA'Last - 1) loop - if (IA (I) /= Null_Item) then - Delete (IA (I)); + if IA /= null and then Free_Items then + for I in IA'First .. (IA'Last - 1) loop + if IA (I) /= Null_Item then + Delete (IA (I)); end if; end loop; end if; - Release (IA); - end Free; + Release (IA); + end Free; ------------------------------------------------------------------------------- - function Default_Menu_Options return Menu_Option_Set + function Default_Menu_Options return Menu_Option_Set is begin - return Get_Options (Null_Menu); - end Default_Menu_Options; + return Get_Options (Null_Menu); + end Default_Menu_Options; - function Default_Item_Options return Item_Option_Set + function Default_Item_Options return Item_Option_Set is begin - return Get_Options (Null_Item); - end Default_Item_Options; + return Get_Options (Null_Item); + end Default_Item_Options; ------------------------------------------------------------------------------- -end Terminal_Interface.Curses.Menus; - \ No newline at end of file +end Terminal_Interface.Curses.Menus; +