X-Git-Url: https://ncurses.scripts.mit.edu/?p=ncurses.git;a=blobdiff_plain;f=Ada95%2Fsrc%2Fterminal_interface-curses-menus.adb;h=ef3a0d3efa2a60b611c1a76aca9b108e8787c5ca;hp=4f218ffbbdbdbe63e02815c580f886db422b6961;hb=db5f7f4f146a91ba8ec7f1df8e9d7f9d2d7c74fd;hpb=55ccd2b959766810cf7db8d1c4462f338ce0afc8 diff --git a/Ada95/src/terminal_interface-curses-menus.adb b/Ada95/src/terminal_interface-curses-menus.adb index 4f218ffb..ef3a0d3e 100644 --- a/Ada95/src/terminal_interface-curses-menus.adb +++ b/Ada95/src/terminal_interface-curses-menus.adb @@ -7,7 +7,7 @@ -- B O D Y -- -- -- ------------------------------------------------------------------------------ --- Copyright (c) 1998,2004 Free Software Foundation, Inc. -- +-- Copyright (c) 1998-2011,2014 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 -- @@ -35,8 +35,8 @@ ------------------------------------------------------------------------------ -- Author: Juergen Pfeifer, 1996 -- Version Control: --- $Revision: 1.25 $ --- $Date: 2004/08/21 21:37:00 $ +-- $Revision: 1.32 $ +-- $Date: 2014/05/24 21:31:05 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; @@ -46,8 +46,6 @@ 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 type C_Item_Array is array (Natural range <>) of aliased Item; @@ -57,24 +55,8 @@ package body Terminal_Interface.Curses.Menus is use type System.Bit_Order; subtype chars_ptr is Interfaces.C.Strings.chars_ptr; - 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 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); - ------------------------------------------------------------------------------ - procedure Request_Name (Key : in Menu_Request_Code; + procedure Request_Name (Key : Menu_Request_Code; Name : out String) is function Request_Name (Key : C_Int) return chars_ptr; @@ -128,10 +110,9 @@ package body Terminal_Interface.Curses.Menus is function Itemname (Itm : Item) return chars_ptr; pragma Import (C, Itemname, "item_name"); - function Freeitem (Itm : Item) return C_Int; + function Freeitem (Itm : Item) return Eti_Error; pragma Import (C, Freeitem, "free_item"); - Res : Eti_Error; Ptr : chars_ptr; begin Ptr := Descname (Itm); @@ -142,25 +123,19 @@ package body Terminal_Interface.Curses.Menus is if Ptr /= Null_Ptr then Interfaces.C.Strings.Free (Ptr); end if; - Res := Freeitem (Itm); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Freeitem (Itm)); 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; + Val : C_Int) return Eti_Error; pragma Import (C, Set_Item_Val, "set_item_value"); - Res : constant Eti_Error := Set_Item_Val (Itm, Boolean'Pos (Value)); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Item_Val (Itm, Boolean'Pos (Value))); end Set_Value; function Value (Itm : Item) return Boolean @@ -188,55 +163,44 @@ package body Terminal_Interface.Curses.Menus is end if; 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; + Opt : Item_Option_Set) return Eti_Error; pragma Import (C, Set_Item_Opts, "set_item_opts"); - 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); - end if; + Eti_Exception (Set_Item_Opts (Itm, Options)); end Set_Options; - procedure Switch_Options (Itm : in Item; - Options : in Item_Option_Set; + 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; + Opt : Item_Option_Set) return Eti_Error; pragma Import (C, Item_Opts_On, "item_opts_on"); function Item_Opts_Off (Itm : Item; - Opt : C_Int) return C_Int; + Opt : Item_Option_Set) return Eti_Error; pragma Import (C, Item_Opts_Off, "item_opts_off"); - Opt : constant C_Int := IOS_2_CInt (Options); - Err : Eti_Error; begin if On then - Err := Item_Opts_On (Itm, Opt); + Eti_Exception (Item_Opts_On (Itm, Options)); else - Err := Item_Opts_Off (Itm, Opt); - end if; - if Err /= E_Ok then - Eti_Exception (Err); + Eti_Exception (Item_Opts_Off (Itm, Options)); end if; end Switch_Options; - procedure Get_Options (Itm : in Item; + procedure Get_Options (Itm : Item; Options : out Item_Option_Set) is - function Item_Opts (Itm : Item) return C_Int; + function Item_Opts (Itm : Item) return Item_Option_Set; pragma Import (C, Item_Opts, "item_opts"); - Res : constant C_Int := Item_Opts (Itm); begin - Options := CInt_2_IOS (Res); + Options := Item_Opts (Itm); end Get_Options; function Get_Options (Itm : Item := Null_Item) return Item_Option_Set @@ -247,7 +211,7 @@ package body Terminal_Interface.Curses.Menus is return Ios; end Get_Options; ------------------------------------------------------------------------------- - procedure Name (Itm : in Item; + procedure Name (Itm : Item; Name : out String) is function Itemname (Itm : Item) return chars_ptr; @@ -256,7 +220,7 @@ package body Terminal_Interface.Curses.Menus is 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"); @@ -264,7 +228,7 @@ package body Terminal_Interface.Curses.Menus is return Fill_String (Itemname (Itm)); end Name; - procedure Description (Itm : in Item; + procedure Description (Itm : Item; Description : out String) is function Descname (Itm : Item) return chars_ptr; @@ -273,7 +237,7 @@ package body Terminal_Interface.Curses.Menus is 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"); @@ -281,18 +245,15 @@ package body Terminal_Interface.Curses.Menus is 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; + Itm : Item) return Eti_Error; pragma Import (C, Set_Curr_Item, "set_current_item"); - Res : constant Eti_Error := Set_Curr_Item (Men, Itm); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Curr_Item (Men, Itm)); end Set_Current; function Current (Men : Menu) return Item @@ -308,18 +269,15 @@ package body Terminal_Interface.Curses.Menus is 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; + Line : C_Int) return Eti_Error; pragma Import (C, Set_Toprow, "set_top_row"); - Res : constant Eti_Error := Set_Toprow (Men, C_Int (Line)); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Toprow (Men, C_Int (Line))); end Set_Top_Row; function Top_Row (Men : Menu) return Line_Position @@ -348,75 +306,60 @@ package body Terminal_Interface.Curses.Menus is 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; + function M_Post (Men : Menu) return Eti_Error; pragma Import (C, M_Post, "post_menu"); - function M_Unpost (Men : Menu) return C_Int; + function M_Unpost (Men : Menu) return Eti_Error; pragma Import (C, M_Unpost, "unpost_menu"); - Res : Eti_Error; begin if Post then - Res := M_Post (Men); + Eti_Exception (M_Post (Men)); else - Res := M_Unpost (Men); - end if; - if Res /= E_Ok then - Eti_Exception (Res); + Eti_Exception (M_Unpost (Men)); end if; 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; + Opt : Menu_Option_Set) return Eti_Error; pragma Import (C, Set_Menu_Opts, "set_menu_opts"); - 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); - end if; + Eti_Exception (Set_Menu_Opts (Men, 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; + Opt : Menu_Option_Set) return Eti_Error; pragma Import (C, Menu_Opts_On, "menu_opts_on"); function Menu_Opts_Off (Men : Menu; - Opt : C_Int) return C_Int; + Opt : Menu_Option_Set) return Eti_Error; pragma Import (C, Menu_Opts_Off, "menu_opts_off"); - Opt : constant C_Int := MOS_2_CInt (Options); - Err : Eti_Error; begin if On then - Err := Menu_Opts_On (Men, Opt); + Eti_Exception (Menu_Opts_On (Men, Options)); else - Err := Menu_Opts_Off (Men, Opt); - end if; - if Err /= E_Ok then - Eti_Exception (Err); + Eti_Exception (Menu_Opts_Off (Men, Options)); end if; 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; + function Menu_Opts (Men : Menu) return Menu_Option_Set; pragma Import (C, Menu_Opts, "menu_opts"); - Res : constant C_Int := Menu_Opts (Men); begin - Options := CInt_2_MOS (Res); + Options := Menu_Opts (Men); end Get_Options; function Get_Options (Men : Menu := Null_Menu) return Menu_Option_Set @@ -427,18 +370,15 @@ package body Terminal_Interface.Curses.Menus is 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; + Win : Window) return Eti_Error; pragma Import (C, Set_Menu_Win, "set_menu_win"); - Res : constant Eti_Error := Set_Menu_Win (Men, Win); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Win (Men, Win)); end Set_Window; function Get_Window (Men : Menu) return Window @@ -451,18 +391,15 @@ package body Terminal_Interface.Curses.Menus is 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; + Win : Window) return Eti_Error; pragma Import (C, Set_Menu_Sub, "set_menu_sub"); - Res : constant Eti_Error := Set_Menu_Sub (Men, Win); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Sub (Men, Win)); end Set_Sub_Window; function Get_Sub_Window (Men : Menu) return Window @@ -475,58 +412,48 @@ package body Terminal_Interface.Curses.Menus is return W; end Get_Sub_Window; - procedure Scale (Men : in Menu; + 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; + Yp, Xp : C_Int_Access) return Eti_Error; pragma Import (C, M_Scale, "scale_menu"); 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); - end if; + Eti_Exception (M_Scale (Men, Y'Access, X'Access)); Lines := Line_Count (Y); Columns := Column_Count (X); end Scale; ------------------------------------------------------------------------------- procedure Position_Cursor (Men : Menu) is - function Pos_Menu_Cursor (Men : Menu) return C_Int; + function Pos_Menu_Cursor (Men : Menu) return Eti_Error; pragma Import (C, Pos_Menu_Cursor, "pos_menu_cursor"); - Res : constant Eti_Error := Pos_Menu_Cursor (Men); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Pos_Menu_Cursor (Men)); end Position_Cursor; ------------------------------------------------------------------------------- - procedure Set_Mark (Men : in Menu; - Mark : in String) + 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; + Mark : Char_Ptr) return Eti_Error; 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; + Eti_Exception (Set_Mark (Men, Txt (Txt'First)'Access)); end Set_Mark; - procedure Mark (Men : in Menu; + procedure Mark (Men : Menu; Mark : out String) is function Get_Menu_Mark (Men : Menu) return chars_ptr; @@ -545,138 +472,125 @@ package body Terminal_Interface.Curses.Menus is ------------------------------------------------------------------------------- procedure Set_Foreground - (Men : in Menu; - Fore : in Character_Attribute_Set := Normal_Video; - Color : in Color_Pair := Color_Pair'First) + (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; + Attr : Attributed_Character) return Eti_Error; 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; + Eti_Exception (Set_Menu_Fore (Men, Ch)); end Set_Foreground; - procedure Foreground (Men : in Menu; + procedure Foreground (Men : Menu; Fore : out Character_Attribute_Set) is - function Menu_Fore (Men : Menu) return C_Chtype; + function Menu_Fore (Men : Menu) return Attributed_Character; pragma Import (C, Menu_Fore, "menu_fore"); begin - Fore := Chtype_To_AttrChar (Menu_Fore (Men)).Attr; + Fore := Menu_Fore (Men).Attr; end Foreground; - procedure Foreground (Men : in Menu; + procedure Foreground (Men : Menu; Fore : out Character_Attribute_Set; Color : out Color_Pair) is - function Menu_Fore (Men : Menu) return C_Chtype; + function Menu_Fore (Men : Menu) return Attributed_Character; pragma Import (C, Menu_Fore, "menu_fore"); begin - Fore := Chtype_To_AttrChar (Menu_Fore (Men)).Attr; - Color := Chtype_To_AttrChar (Menu_Fore (Men)).Color; + Fore := Menu_Fore (Men).Attr; + Color := 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) + (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; + Attr : Attributed_Character) return Eti_Error; 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)); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Back (Men, Ch)); end Set_Background; - procedure Background (Men : in Menu; + procedure Background (Men : Menu; Back : out Character_Attribute_Set) is - function Menu_Back (Men : Menu) return C_Chtype; + function Menu_Back (Men : Menu) return Attributed_Character; pragma Import (C, Menu_Back, "menu_back"); begin - Back := Chtype_To_AttrChar (Menu_Back (Men)).Attr; + Back := Menu_Back (Men).Attr; end Background; - procedure Background (Men : in Menu; + procedure Background (Men : Menu; Back : out Character_Attribute_Set; Color : out Color_Pair) is - function Menu_Back (Men : Menu) return C_Chtype; + function Menu_Back (Men : Menu) return Attributed_Character; pragma Import (C, Menu_Back, "menu_back"); begin - Back := Chtype_To_AttrChar (Menu_Back (Men)).Attr; - Color := Chtype_To_AttrChar (Menu_Back (Men)).Color; + Back := Menu_Back (Men).Attr; + Color := 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; + Attr : Attributed_Character) return Eti_Error; pragma Import (C, Set_Menu_Grey, "set_menu_grey"); Ch : constant Attributed_Character := (Ch => Character'First, Color => Color, Attr => Grey); - Res : constant Eti_Error := Set_Menu_Grey (Men, AttrChar_To_Chtype (Ch)); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Grey (Men, Ch)); end Set_Grey; - procedure Grey (Men : in Menu; + procedure Grey (Men : Menu; Grey : out Character_Attribute_Set) is - function Menu_Grey (Men : Menu) return C_Chtype; + function Menu_Grey (Men : Menu) return Attributed_Character; pragma Import (C, Menu_Grey, "menu_grey"); begin - Grey := Chtype_To_AttrChar (Menu_Grey (Men)).Attr; + Grey := Menu_Grey (Men).Attr; end Grey; - procedure Grey (Men : in Menu; + procedure Grey (Men : Menu; Grey : out Character_Attribute_Set; Color : out Color_Pair) is - function Menu_Grey (Men : Menu) return C_Chtype; + function Menu_Grey (Men : Menu) return Attributed_Character; pragma Import (C, Menu_Grey, "menu_grey"); begin - Grey := Chtype_To_AttrChar (Menu_Grey (Men)).Attr; - Color := Chtype_To_AttrChar (Menu_Grey (Men)).Color; + Grey := Menu_Grey (Men).Attr; + Color := 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; + Ch : C_Int) return Eti_Error; pragma Import (C, Set_Menu_Pad, "set_menu_pad"); - Res : constant Eti_Error := Set_Menu_Pad (Men, - C_Int (Character'Pos (Pad))); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Pad (Men, C_Int (Character'Pos (Pad)))); end Set_Pad_Character; - procedure Pad_Character (Men : in Menu; + procedure Pad_Character (Men : Menu; Pad : out Character) is function Menu_Pad (Men : Menu) return C_Int; @@ -685,48 +599,41 @@ package body Terminal_Interface.Curses.Menus is 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) + 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; + D, R, C : C_Int) return Eti_Error; 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; + Eti_Exception (Set_Spacing (Men, + C_Int (Descr), + C_Int (Row), + C_Int (Col))); end Set_Spacing; - procedure Spacing (Men : in Menu; + 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; + D, R, C : C_Int_Access) return Eti_Error; 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); - end if; + Eti_Exception (Get_Spacing (Men, + D'Access, + R'Access, + C'Access)); + Descr := Column_Position (D); + Row := Line_Position (R); + Col := Column_Position (C); end Spacing; ------------------------------------------------------------------------------- function Set_Pattern (Men : Menu; @@ -734,7 +641,7 @@ package body Terminal_Interface.Curses.Menus is is type Char_Ptr is access all Interfaces.C.char; function Set_Pattern (Men : Menu; - Pattern : Char_Ptr) return C_Int; + Pattern : Char_Ptr) return Eti_Error; pragma Import (C, Set_Pattern, "set_menu_pattern"); S : char_array (0 .. Text'Length); @@ -744,15 +651,15 @@ package body Terminal_Interface.Curses.Menus is 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 E_No_Match => + return False; when others => Eti_Exception (Res); - return False; + return True; end case; end Set_Pattern; - procedure Pattern (Men : in Menu; + procedure Pattern (Men : Menu; Text : out String) is function Get_Pattern (Men : Menu) return chars_ptr; @@ -761,98 +668,80 @@ package body Terminal_Interface.Curses.Menus is 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; + Col : C_Int) return Eti_Error; pragma Import (C, Set_Menu_Fmt, "set_menu_format"); - Res : constant Eti_Error := Set_Menu_Fmt (Men, - C_Int (Lines), - C_Int (Columns)); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Fmt (Men, + C_Int (Lines), + C_Int (Columns))); + end Set_Format; - procedure Format (Men : in Menu; + 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; + Y, X : C_Int_Access) return Eti_Error; pragma Import (C, Menu_Fmt, "menu_format"); 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); - else - Lines := Line_Count (L); - Columns := Column_Count (C); - end if; + Eti_Exception (Menu_Fmt (Men, L'Access, C'Access)); + Lines := Line_Count (L); + Columns := Column_Count (C); 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; + Proc : Menu_Hook_Function) return Eti_Error; pragma Import (C, Set_Item_Init, "set_item_init"); - Res : constant Eti_Error := Set_Item_Init (Men, Proc); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Item_Init (Men, Proc)); 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; + Proc : Menu_Hook_Function) return Eti_Error; pragma Import (C, Set_Item_Term, "set_item_term"); - Res : constant Eti_Error := Set_Item_Term (Men, Proc); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Item_Term (Men, Proc)); 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; + Proc : Menu_Hook_Function) return Eti_Error; pragma Import (C, Set_Menu_Init, "set_menu_init"); - Res : constant Eti_Error := Set_Menu_Init (Men, Proc); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Init (Men, Proc)); 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; + Proc : Menu_Hook_Function) return Eti_Error; pragma Import (C, Set_Menu_Term, "set_menu_term"); - Res : constant Eti_Error := Set_Menu_Term (Men, Proc); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Menu_Term (Men, Proc)); end Set_Menu_Term_Hook; function Get_Item_Init_Hook (Men : Menu) return Menu_Hook_Function @@ -887,23 +776,19 @@ package body Terminal_Interface.Curses.Menus is 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; + Items : System.Address) return Eti_Error; pragma Import (C, Set_Items, "set_menu_items"); - Res : Eti_Error; begin - pragma Assert (Items (Items'Last) = Null_Item); - if Items (Items'Last) /= Null_Item then + pragma Assert (Items.all (Items'Last) = Null_Item); + if Items.all (Items'Last) /= Null_Item then raise Menu_Exception; else - Res := Set_Items (Men, Items.all'Address); - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Set_Items (Men, Items.all'Address)); end if; end Redefine; @@ -925,7 +810,7 @@ package body Terminal_Interface.Curses.Menus is P : Pointer := C_Mitems (Men); begin - if P = null or else Index not in 1 .. Item_Count (Men) then + if P = null or else Index > Item_Count (Men) then raise Menu_Exception; else P := P + ptrdiff_t (C_Int (Index) - 1); @@ -941,8 +826,8 @@ package body Terminal_Interface.Curses.Menus is M : Menu; begin - pragma Assert (Items (Items'Last) = Null_Item); - if Items (Items'Last) /= Null_Item then + pragma Assert (Items.all (Items'Last) = Null_Item); + if Items.all (Items'Last) /= Null_Item then raise Menu_Exception; else M := Newmenu (Items.all'Address); @@ -955,14 +840,11 @@ package body Terminal_Interface.Curses.Menus is procedure Delete (Men : in out Menu) is - function Free (Men : Menu) return C_Int; + function Free (Men : Menu) return Eti_Error; pragma Import (C, Free, "free_menu"); - Res : constant Eti_Error := Free (Men); begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; + Eti_Exception (Free (Men)); Men := Null_Menu; end Delete; @@ -971,34 +853,34 @@ package body Terminal_Interface.Curses.Menus is Key : Key_Code) return Driver_Result is function Driver (Men : Menu; - Key : C_Int) return C_Int; + Key : C_Int) return Eti_Error; pragma Import (C, Driver, "menu_driver"); 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; - when others => - Eti_Exception (R); - end case; - end if; - return Menu_Ok; + 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); + return Menu_Ok; + end case; end Driver; procedure Free (IA : in out Item_Array_Access; - Free_Items : in Boolean := False) + Free_Items : Boolean := False) is 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.all (I) /= Null_Item then + Delete (IA.all (I)); end if; end loop; end if;