Ada95/ada_include/terminal_interface-curses-menus.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                           GNAT ncurses Binding                           --
   4 --                                                                          --
   5 --                      Terminal_Interface.Curses.Menus                     --
   6 --                                                                          --
   7 --                                 B O D Y                                  --
   8 --                                                                          --
   9 --  Version 00.92                                                           --
  10 --                                                                          --
  11 --  The ncurses Ada95 binding is copyrighted 1996 by                        --
  12 --  Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de                     --
  13 --                                                                          --
  14 --  Permission is hereby granted to reproduce and distribute this           --
  15 --  binding by any means and for any fee, whether alone or as part          --
  16 --  of a larger distribution, in source or in binary form, PROVIDED         --
  17 --  this notice is included with any such distribution, and is not          --
  18 --  removed from any of its header files. Mention of ncurses and the        --
  19 --  author of this binding in any applications linked with it is            --
  20 --  highly appreciated.                                                     --
  21 --                                                                          --
  22 --  This binding comes AS IS with no warranty, implied or expressed.        --
  23 ------------------------------------------------------------------------------
  24 --  Version Control:
  25 --  $Revision: 1.7 $
  26 ------------------------------------------------------------------------------
  27 with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
  28
  29 with Interfaces.C; use Interfaces.C;
  30 with Interfaces.C.Strings;
  31 with Terminal_Interface.Curses;
  32
  33 with Ada.Unchecked_Deallocation;
  34 with Unchecked_Conversion;
  35
  36 package body Terminal_Interface.Curses.Menus is
  37
  38    use type System.Bit_Order;
  39    subtype chars_ptr is Interfaces.C.Strings.chars_ptr;
  40
  41    function MOS_2_CInt is new
  42      Unchecked_Conversion (Menu_Option_Set,
  43                            C_Int);
  44
  45    function CInt_2_MOS is new
  46      Unchecked_Conversion (C_Int,
  47                            Menu_Option_Set);
  48
  49    function IOS_2_CInt is new
  50      Unchecked_Conversion (Item_Option_Set,
  51                            C_Int);
  52
  53    function CInt_2_IOS is new
  54      Unchecked_Conversion (C_Int,
  55                            Item_Option_Set);
  56
  57 ------------------------------------------------------------------------------
  58    procedure Free_Allocated_Items is
  59      new Ada.Unchecked_Deallocation (Item_Array, Item_Array_Access);
  60
  61    procedure Free_User_Wrapper is
  62      new Ada.Unchecked_Deallocation (Ada_User_Wrapper,
  63                                      Ada_User_Wrapper_Access);
  64
  65 ------------------------------------------------------------------------------
  66    procedure Request_Name (Key  : in Menu_Request_Code;
  67                                 Name : out String)
  68    is
  69       function Request_Name (Key : C_Int) return chars_ptr;
  70       pragma Import (C, Request_Name, "menu_request_name");
  71    begin
  72       Fill_String (Request_Name (C_Int (Key)), Name);
  73    end Request_Name;
  74
  75    --  !!! W A R N I N G !!!
  76    --  If you want to port this binding to a non ncurses version of the
  77    --  ETI, this must be rewritten. In ncurses the menu items and
  78    --  descriptions may be automatic variables, because ncurses copies
  79    --  the parameters into private allocated internal structures.
  80    --  Other implementations don't do that usually, so depending on
  81    --  scopes you may see unexpected results.
  82    function Create (Name        : String;
  83                     Description : String := "") return Item
  84    is
  85       type Char_Ptr is access all Interfaces.C.Char;
  86       function Newitem (Name, Desc : Char_Ptr) return Item;
  87       pragma Import (C, Newitem, "new_item");
  88
  89       Name_Str : char_array (0 .. Name'Length);
  90       Desc_Str : char_array (0 .. Description'Length);
  91       Name_Len, Desc_Len : size_t;
  92       Result : Item;
  93    begin
  94       To_C (Name, Name_Str, Name_Len);
  95       To_C (Description, Desc_Str, Desc_Len);
  96       Result := Newitem (Name_Str (Name_Str'First)'Access,
  97                          Desc_Str (Desc_Str'First)'Access);
  98       if Result = Null_Item then
  99          raise Eti_System_Error;
 100       end if;
 101       return Result;
 102    end Create;
 103
 104    procedure Delete (Itm : in out Item)
 105    is
 106       function Freeitem (Itm : Item) return C_Int;
 107       pragma Import (C, Freeitem, "free_item");
 108
 109       Res : constant Eti_Error := Freeitem (Itm);
 110    begin
 111       if Res /= E_Ok then
 112          Eti_Exception (Res);
 113       end if;
 114       Itm := Null_Item;
 115    end Delete;
 116 -------------------------------------------------------------------------------
 117    procedure Set_Value (Itm   : in Item;
 118                         Value : in Boolean := True)
 119    is
 120       function Set_Item_Val (Itm : Item;
 121                              Val : C_Int) return C_Int;
 122       pragma Import (C, Set_Item_Val, "set_item_value");
 123
 124       Res : constant Eti_Error := Set_Item_Val (Itm, Boolean'Pos (Value));
 125    begin
 126       if  Res /= E_Ok then
 127          Eti_Exception (Res);
 128       end if;
 129    end Set_Value;
 130
 131    function Value (Itm : Item) return Boolean
 132    is
 133       function Item_Val (Itm : Item) return C_Int;
 134       pragma Import (C, Item_Val, "item_value");
 135    begin
 136       if Item_Val (Itm) = Curses_False then
 137          return False;
 138       else
 139          return True;
 140       end if;
 141    end Value;
 142
 143 -------------------------------------------------------------------------------
 144    function Visible (Itm : Item) return Boolean
 145    is
 146       function Item_Vis (Itm : Item) return C_Int;
 147       pragma Import (C, Item_Vis, "item_visible");
 148    begin
 149       if Item_Vis (Itm) = Curses_False then
 150          return False;
 151       else
 152          return True;
 153       end if;
 154    end Visible;
 155 -------------------------------------------------------------------------------
 156    procedure Normalize_Item_Options (Options : in out C_Int);
 157    pragma Import (C, Normalize_Item_Options, "_nc_ada_normalize_item_opts");
 158
 159    procedure Set_Options (Itm     : in Item;
 160                           Options : in Item_Option_Set)
 161    is
 162       function Set_Item_Opts (Itm : Item;
 163                               Opt : C_Int) return C_Int;
 164       pragma Import (C, Set_Item_Opts, "set_item_opts");
 165
 166       Opt : C_Int := IOS_2_CInt (Options);
 167       Res : Eti_Error;
 168    begin
 169       Normalize_Item_Options (Opt);
 170       Res := Set_Item_Opts (Itm, Opt);
 171       if Res /= E_Ok then
 172          Eti_Exception (Res);
 173       end if;
 174    end Set_Options;
 175
 176    procedure Switch_Options (Itm     : in Item;
 177                              Options : in Item_Option_Set;
 178                              On      : Boolean := True)
 179    is
 180       function Item_Opts_On (Itm : Item;
 181                              Opt : C_Int) return C_Int;
 182       pragma Import (C, Item_Opts_On, "item_opts_on");
 183       function Item_Opts_Off (Itm : Item;
 184                               Opt : C_Int) return C_Int;
 185       pragma Import (C, Item_Opts_Off, "item_opts_off");
 186
 187       Opt : C_Int := IOS_2_CInt (Options);
 188       Err : Eti_Error;
 189    begin
 190       Normalize_Item_Options (Opt);
 191       if On then
 192          Err := Item_Opts_On (Itm, Opt);
 193       else
 194          Err := Item_Opts_Off (Itm, Opt);
 195       end if;
 196       if Err /= E_Ok then
 197          Eti_Exception (Err);
 198       end if;
 199    end Switch_Options;
 200
 201    procedure Get_Options (Itm     : in  Item;
 202                           Options : out Item_Option_Set)
 203    is
 204       function Item_Opts (Itm : Item) return C_Int;
 205       pragma Import (C, Item_Opts, "item_opts");
 206
 207       Res : C_Int := Item_Opts (Itm);
 208    begin
 209       Normalize_Item_Options (Res);
 210       Options := CInt_2_IOS (Res);
 211    end Get_Options;
 212
 213    function Get_Options (Itm : Item := Null_Item) return Item_Option_Set
 214    is
 215       Ios : Item_Option_Set;
 216    begin
 217       Get_Options (Itm, Ios);
 218       return Ios;
 219    end Get_Options;
 220 -------------------------------------------------------------------------------
 221    procedure Name (Itm  : in Item;
 222                    Name : out String)
 223    is
 224       function Itemname (Itm : Item) return chars_ptr;
 225       pragma Import (C, Itemname, "item_name");
 226    begin
 227       Fill_String (Itemname (Itm), Name);
 228    end Name;
 229
 230    procedure Description (Itm         : in Item;
 231                           Description : out String)
 232    is
 233       function Descname (Itm  : Item) return chars_ptr;
 234       pragma Import (C, Descname, "item_description");
 235    begin
 236       Fill_String (Descname (Itm), Description);
 237    end Description;
 238 -------------------------------------------------------------------------------
 239    procedure Set_Current (Men : in Menu;
 240                           Itm : in Item)
 241    is
 242       function Set_Curr_Item (Men : Menu;
 243                               Itm : Item) return C_Int;
 244       pragma Import (C, Set_Curr_Item, "set_current_item");
 245
 246       Res : constant Eti_Error := Set_Curr_Item (Men, Itm);
 247    begin
 248       if Res /= E_Ok then
 249          Eti_Exception (Res);
 250       end if;
 251    end Set_Current;
 252
 253    function Current (Men : Menu) return Item
 254    is
 255       function Curr_Item (Men : Menu) return Item;
 256       pragma Import (C, Curr_Item, "current_item");
 257
 258       Res : constant Item := Curr_Item (Men);
 259    begin
 260       if Res = Null_Item then
 261          raise Menu_Exception;
 262       end if;
 263       return Res;
 264    end Current;
 265
 266    procedure Set_Top_Row (Men  : in Menu;
 267                           Line : in Line_Position)
 268    is
 269       function Set_Toprow (Men  : Menu;
 270                            Line : C_Int) return C_Int;
 271       pragma Import (C, Set_Toprow, "set_top_row");
 272
 273       Res : constant Eti_Error := Set_Toprow (Men, C_Int (Line));
 274    begin
 275       if  Res /= E_Ok then
 276          Eti_Exception (Res);
 277       end if;
 278    end Set_Top_Row;
 279
 280    function Top_Row (Men : Menu) return Line_Position
 281    is
 282       function Toprow (Men : Menu) return C_Int;
 283       pragma Import (C, Toprow, "top_row");
 284
 285       Res : constant C_Int := Toprow (Men);
 286    begin
 287       if Res = Curses_Err then
 288          raise Menu_Exception;
 289       end if;
 290       return Line_Position (Res);
 291    end Top_Row;
 292
 293    function Get_Index (Itm : Item) return Positive
 294    is
 295       function Get_Itemindex (Itm : Item) return C_Int;
 296       pragma Import (C, Get_Itemindex, "item_index");
 297
 298       Res : constant C_Int := Get_Itemindex (Itm);
 299    begin
 300       if Res = Curses_Err then
 301          raise Menu_Exception;
 302       end if;
 303       return Positive (Natural (Res) + Positive'First);
 304    end Get_Index;
 305 -------------------------------------------------------------------------------
 306    procedure Post (Men  : in Menu;
 307                    Post : in Boolean := True)
 308    is
 309       function M_Post (Men : Menu) return C_Int;
 310       pragma Import (C, M_Post, "post_menu");
 311       function M_Unpost (Men : Menu) return C_Int;
 312       pragma Import (C, M_Unpost, "unpost_menu");
 313
 314       Res : Eti_Error;
 315    begin
 316       if Post then
 317          Res := M_Post (Men);
 318       else
 319          Res := M_Unpost (Men);
 320       end if;
 321       if Res /= E_Ok then
 322          Eti_Exception (Res);
 323       end if;
 324    end Post;
 325 -------------------------------------------------------------------------------
 326    procedure Normalize_Menu_Options (Options : in out C_Int);
 327    pragma Import (C, Normalize_Menu_Options, "_nc_ada_normalize_menu_opts");
 328
 329    procedure Set_Options (Men     : in Menu;
 330                           Options : in Menu_Option_Set)
 331    is
 332       function Set_Menu_Opts (Men : Menu;
 333                               Opt : C_Int) return C_Int;
 334       pragma Import (C, Set_Menu_Opts, "set_menu_opts");
 335
 336       Opt : C_Int := MOS_2_CInt (Options);
 337       Res : Eti_Error;
 338    begin
 339       Normalize_Menu_Options (Opt);
 340       Res := Set_Menu_Opts (Men, Opt);
 341       if  Res /= E_Ok then
 342          Eti_Exception (Res);
 343       end if;
 344    end Set_Options;
 345
 346    procedure Switch_Options (Men     : in Menu;
 347                              Options : in Menu_Option_Set;
 348                              On      : in Boolean := True)
 349    is
 350       function Menu_Opts_On (Men : Menu;
 351                              Opt : C_Int) return C_Int;
 352       pragma Import (C, Menu_Opts_On, "menu_opts_on");
 353       function Menu_Opts_Off (Men : Menu;
 354                               Opt : C_Int) return C_Int;
 355       pragma Import (C, Menu_Opts_Off, "menu_opts_off");
 356
 357       Opt : C_Int := MOS_2_CInt (Options);
 358       Err : Eti_Error;
 359    begin
 360       Normalize_Menu_Options (Opt);
 361       if On then
 362          Err := Menu_Opts_On  (Men, Opt);
 363       else
 364          Err := Menu_Opts_Off (Men, Opt);
 365       end if;
 366       if Err /= E_Ok then
 367          Eti_Exception (Err);
 368       end if;
 369    end Switch_Options;
 370
 371    procedure Get_Options (Men     : in  Menu;
 372                                Options : out Menu_Option_Set)
 373    is
 374       function Menu_Opts (Men : Menu) return C_Int;
 375       pragma Import (C, Menu_Opts, "menu_opts");
 376
 377       Res : C_Int := Menu_Opts (Men);
 378    begin
 379       Normalize_Menu_Options (Res);
 380       Options := CInt_2_MOS (Res);
 381    end Get_Options;
 382
 383    function Get_Options (Men : Menu := Null_Menu) return Menu_Option_Set
 384    is
 385       Mos : Menu_Option_Set;
 386    begin
 387       Get_Options (Men, Mos);
 388       return Mos;
 389    end Get_Options;
 390 -------------------------------------------------------------------------------
 391    procedure Set_Window (Men : in Menu;
 392                          Win : in Window)
 393    is
 394       function Set_Menu_Win (Men : Menu;
 395                              Win : Window) return C_Int;
 396       pragma Import (C, Set_Menu_Win, "set_menu_win");
 397
 398       Res : constant Eti_Error := Set_Menu_Win (Men, Win);
 399    begin
 400       if  Res /= E_Ok then
 401          Eti_Exception (Res);
 402       end if;
 403    end Set_Window;
 404
 405    function Get_Window (Men : Menu) return Window
 406    is
 407       function Menu_Win (Men : Menu) return Window;
 408       pragma Import (C, Menu_Win, "menu_win");
 409
 410       W : constant Window := Menu_Win (Men);
 411    begin
 412       return W;
 413    end Get_Window;
 414
 415    procedure Set_Sub_Window (Men : in Menu;
 416                              Win : in Window)
 417    is
 418       function Set_Menu_Sub (Men : Menu;
 419                              Win : Window) return C_Int;
 420       pragma Import (C, Set_Menu_Sub, "set_menu_sub");
 421
 422       Res : constant Eti_Error := Set_Menu_Sub (Men, Win);
 423    begin
 424       if  Res /= E_Ok then
 425          Eti_Exception (Res);
 426       end if;
 427    end Set_Sub_Window;
 428
 429    function Get_Sub_Window (Men : Menu) return Window
 430    is
 431       function Menu_Sub (Men : Menu) return Window;
 432       pragma Import (C, Menu_Sub, "menu_sub");
 433
 434       W : constant Window := Menu_Sub (Men);
 435    begin
 436       return W;
 437    end Get_Sub_Window;
 438
 439    procedure Scale (Men     : in Menu;
 440                     Lines   : out Line_Count;
 441                     Columns : out Column_Count)
 442    is
 443       type C_Int_Access is access all C_Int;
 444       function M_Scale (Men    : Menu;
 445                         Yp, Xp : C_Int_Access) return C_Int;
 446       pragma Import (C, M_Scale, "scale_menu");
 447
 448       X, Y : aliased C_Int;
 449       Res  : constant Eti_Error := M_Scale (Men, Y'Access, X'Access);
 450    begin
 451       if Res /= E_Ok then
 452          Eti_Exception (Res);
 453       end if;
 454       Lines := Line_Count (Y);
 455       Columns := Column_Count (X);
 456    end Scale;
 457 -------------------------------------------------------------------------------
 458    procedure Position_Cursor (Men : Menu)
 459    is
 460       function Pos_Menu_Cursor (Men : Menu) return C_Int;
 461       pragma Import (C, Pos_Menu_Cursor, "pos_menu_cursor");
 462
 463       Res : constant Eti_Error := Pos_Menu_Cursor (Men);
 464    begin
 465       if  Res /= E_Ok then
 466          Eti_Exception (Res);
 467       end if;
 468    end Position_Cursor;
 469
 470 -------------------------------------------------------------------------------
 471    procedure Set_Mark (Men  : in Menu;
 472                        Mark : in String)
 473    is
 474       type Char_Ptr is access all Interfaces.C.Char;
 475       function Set_Mark (Men  : Menu;
 476                          Mark : Char_Ptr) return C_Int;
 477       pragma Import (C, Set_Mark, "set_menu_mark");
 478
 479       Txt : char_array (0 .. Mark'Length);
 480       Len : size_t;
 481       Res : Eti_Error;
 482    begin
 483       To_C (Mark, Txt, Len);
 484       Res := Set_Mark (Men, Txt (Txt'First)'Access);
 485       if Res /= E_Ok then
 486          Eti_Exception (Res);
 487       end if;
 488    end Set_Mark;
 489
 490    procedure Mark (Men  : in  Menu;
 491                    Mark : out String)
 492    is
 493       function Get_Menu_Mark (Men : Menu) return chars_ptr;
 494       pragma Import (C, Get_Menu_Mark, "menu_mark");
 495    begin
 496       Fill_String (Get_Menu_Mark (Men), Mark);
 497    end Mark;
 498
 499 -------------------------------------------------------------------------------
 500    procedure Set_Foreground
 501      (Men   : in Menu;
 502       Fore  : in Character_Attribute_Set := Normal_Video;
 503       Color : in Color_Pair := Color_Pair'First)
 504    is
 505       function Set_Menu_Fore (Men  : Menu;
 506                               Attr : C_Int) return C_Int;
 507       pragma Import (C, Set_Menu_Fore, "set_menu_fore");
 508
 509       Ch : constant Attributed_Character := (Ch    => Character'First,
 510                                              Color => Color,
 511                                              Attr  => Fore);
 512       Res : constant Eti_Error := Set_Menu_Fore (Men, Chtype_To_CInt (Ch));
 513    begin
 514       if  Res /= E_Ok then
 515          Eti_Exception (Res);
 516       end if;
 517    end Set_Foreground;
 518
 519    procedure Foreground (Men  : in  Menu;
 520                          Fore : out Character_Attribute_Set)
 521    is
 522       function Menu_Fore (Men : Menu) return C_Int;
 523       pragma Import (C, Menu_Fore, "menu_fore");
 524    begin
 525       Fore := CInt_To_Chtype (Menu_Fore (Men)).Attr;
 526    end Foreground;
 527
 528    procedure Foreground (Men   : in  Menu;
 529                          Fore  : out Character_Attribute_Set;
 530                          Color : out Color_Pair)
 531    is
 532       function Menu_Fore (Men : Menu) return C_Int;
 533       pragma Import (C, Menu_Fore, "menu_fore");
 534    begin
 535       Fore  := CInt_To_Chtype (Menu_Fore (Men)).Attr;
 536       Color := CInt_To_Chtype (Menu_Fore (Men)).Color;
 537    end Foreground;
 538
 539    procedure Set_Background
 540      (Men   : in Menu;
 541       Back  : in Character_Attribute_Set := Normal_Video;
 542       Color : in Color_Pair := Color_Pair'First)
 543    is
 544       function Set_Menu_Back (Men  : Menu;
 545                               Attr : C_Int) return C_Int;
 546       pragma Import (C, Set_Menu_Back, "set_menu_back");
 547
 548       Ch : constant Attributed_Character := (Ch    => Character'First,
 549                                              Color => Color,
 550                                              Attr  => Back);
 551       Res : constant Eti_Error := Set_Menu_Back (Men, Chtype_To_CInt (Ch));
 552    begin
 553       if  Res /= E_Ok then
 554          Eti_Exception (Res);
 555       end if;
 556    end Set_Background;
 557
 558    procedure Background (Men  : in  Menu;
 559                          Back : out Character_Attribute_Set)
 560    is
 561       function Menu_Back (Men : Menu) return C_Int;
 562       pragma Import (C, Menu_Back, "menu_back");
 563    begin
 564       Back := CInt_To_Chtype (Menu_Back (Men)).Attr;
 565    end Background;
 566
 567    procedure Background (Men   : in  Menu;
 568                          Back  : out Character_Attribute_Set;
 569                          Color : out Color_Pair)
 570    is
 571       function Menu_Back (Men : Menu) return C_Int;
 572       pragma Import (C, Menu_Back, "menu_back");
 573    begin
 574       Back  := CInt_To_Chtype (Menu_Back (Men)).Attr;
 575       Color := CInt_To_Chtype (Menu_Back (Men)).Color;
 576    end Background;
 577
 578    procedure Set_Grey (Men   : in Menu;
 579                        Grey  : in Character_Attribute_Set := Normal_Video;
 580                        Color : in Color_Pair := Color_Pair'First)
 581    is
 582       function Set_Menu_Grey (Men  : Menu;
 583                               Attr : C_Int) return C_Int;
 584       pragma Import (C, Set_Menu_Grey, "set_menu_grey");
 585
 586       Ch : constant Attributed_Character := (Ch    => Character'First,
 587                                              Color => Color,
 588                                              Attr  => Grey);
 589
 590       Res : constant Eti_Error := Set_Menu_Grey (Men, Chtype_To_CInt (Ch));
 591    begin
 592       if  Res /= E_Ok then
 593          Eti_Exception (Res);
 594       end if;
 595    end Set_Grey;
 596
 597    procedure Grey (Men  : in  Menu;
 598                    Grey : out Character_Attribute_Set)
 599    is
 600       function Menu_Grey (Men : Menu) return C_Int;
 601       pragma Import (C, Menu_Grey, "menu_grey");
 602    begin
 603       Grey := CInt_To_Chtype (Menu_Grey (Men)).Attr;
 604    end Grey;
 605
 606    procedure Grey (Men  : in  Menu;
 607                    Grey : out Character_Attribute_Set;
 608                    Color : out Color_Pair)
 609    is
 610       function Menu_Grey (Men : Menu) return C_Int;
 611       pragma Import (C, Menu_Grey, "menu_grey");
 612    begin
 613       Grey  := CInt_To_Chtype (Menu_Grey (Men)).Attr;
 614       Color := CInt_To_Chtype (Menu_Grey (Men)).Color;
 615    end Grey;
 616
 617    procedure Set_Pad_Character (Men : in Menu;
 618                                 Pad : in Character := Space)
 619    is
 620       function Set_Menu_Pad (Men : Menu;
 621                              Ch  : C_Int) return C_Int;
 622       pragma Import (C, Set_Menu_Pad, "set_menu_pad");
 623
 624       Res : constant Eti_Error := Set_Menu_Pad (Men,
 625                                                 C_Int (Character'Pos (Pad)));
 626    begin
 627       if Res /= E_Ok then
 628          Eti_Exception (Res);
 629       end if;
 630    end Set_Pad_Character;
 631
 632    procedure Pad_Character (Men : in  Menu;
 633                             Pad : out Character)
 634    is
 635       function Menu_Pad (Men : Menu) return C_Int;
 636       pragma Import (C, Menu_Pad, "menu_pad");
 637    begin
 638       Pad := Character'Val (Menu_Pad (Men));
 639    end Pad_Character;
 640 -------------------------------------------------------------------------------
 641    procedure Set_Spacing (Men   : in Menu;
 642                           Descr : in Column_Position := 0;
 643                           Row   : in Line_Position   := 0;
 644                           Col   : in Column_Position := 0)
 645    is
 646       function Set_Spacing (Men     : Menu;
 647                             D, R, C : C_Int) return C_Int;
 648       pragma Import (C, Set_Spacing, "set_menu_spacing");
 649
 650       Res : constant Eti_Error := Set_Spacing (Men,
 651                                                C_Int (Descr),
 652                                                C_Int (Row),
 653                                                C_Int (Col));
 654    begin
 655       if Res /= E_Ok then
 656          Eti_Exception (Res);
 657       end if;
 658    end Set_Spacing;
 659
 660    procedure Spacing (Men   : in Menu;
 661                       Descr : out Column_Position;
 662                       Row   : out Line_Position;
 663                       Col   : out Column_Position)
 664    is
 665       type C_Int_Access is access all C_Int;
 666       function Get_Spacing (Men     : Menu;
 667                             D, R, C : C_Int_Access) return C_Int;
 668       pragma Import (C, Get_Spacing, "menu_spacing");
 669
 670       D, R, C : aliased C_Int;
 671       Res : constant Eti_Error := Get_Spacing (Men,
 672                                                D'Access,
 673                                                R'Access,
 674                                                C'Access);
 675    begin
 676       if Res /= E_Ok then
 677          Eti_Exception (Res);
 678       else
 679          Descr := Column_Position (D);
 680          Row   := Line_Position (R);
 681          Col   := Column_Position (C);
 682       end if;
 683    end Spacing;
 684 -------------------------------------------------------------------------------
 685    function Set_Pattern (Men  : Menu;
 686                          Text : String) return Boolean
 687    is
 688       type Char_Ptr is access all Interfaces.C.Char;
 689       function Set_Pattern (Men     : Menu;
 690                             Pattern : Char_Ptr) return C_Int;
 691       pragma Import (C, Set_Pattern, "set_menu_pattern");
 692
 693       S   : char_array (0 .. Text'Length);
 694       L   : size_t;
 695       Res : Eti_Error;
 696    begin
 697       To_C (Text, S, L);
 698       Res := Set_Pattern (Men, S (S'First)'Access);
 699       case Res is
 700          when E_No_Match => return False;
 701          when E_Ok       => return True;
 702          when others =>
 703             Eti_Exception (Res);
 704             return False;
 705       end case;
 706    end Set_Pattern;
 707
 708    procedure Pattern (Men  : in  Menu;
 709                            Text : out String)
 710    is
 711       function Get_Pattern (Men : Menu) return chars_ptr;
 712       pragma Import (C, Get_Pattern, "menu_pattern");
 713    begin
 714       Fill_String (Get_Pattern (Men), Text);
 715    end Pattern;
 716 -------------------------------------------------------------------------------
 717    procedure Set_Format (Men     : in Menu;
 718                          Lines   : in Line_Count;
 719                          Columns : in Column_Count)
 720    is
 721       function Set_Menu_Fmt (Men : Menu;
 722                              Lin : C_Int;
 723                              Col : C_Int) return C_Int;
 724       pragma Import (C, Set_Menu_Fmt, "set_menu_format");
 725
 726       Res : constant Eti_Error := Set_Menu_Fmt (Men,
 727                                                 C_Int (Lines),
 728                                                 C_Int (Columns));
 729    begin
 730       if  Res /= E_Ok then
 731          Eti_Exception (Res);
 732       end if;
 733    end Set_Format;
 734
 735    procedure Format (Men     : in  Menu;
 736                      Lines   : out Line_Count;
 737                      Columns : out Column_Count)
 738    is
 739       type C_Int_Access is access all C_Int;
 740       function Menu_Fmt (Men  : Menu;
 741                          Y, X : C_Int_Access) return C_Int;
 742       pragma Import (C, Menu_Fmt, "menu_format");
 743
 744       L, C : aliased C_Int;
 745       Res  : constant Eti_Error := Menu_Fmt (Men, L'Access, C'Access);
 746    begin
 747       if Res /= E_Ok then
 748          Eti_Exception (Res);
 749       else
 750          Lines   := Line_Count (L);
 751          Columns := Column_Count (C);
 752       end if;
 753    end Format;
 754 -------------------------------------------------------------------------------
 755    procedure Set_Item_Init_Hook (Men  : in Menu;
 756                                  Proc : in Menu_Hook_Function)
 757    is
 758       function Set_Item_Init (Men  : Menu;
 759                               Proc : Menu_Hook_Function) return C_Int;
 760       pragma Import (C, Set_Item_Init, "set_item_init");
 761
 762       Res : constant Eti_Error := Set_Item_Init (Men, Proc);
 763    begin
 764       if  Res /= E_Ok then
 765          Eti_Exception (Res);
 766       end if;
 767    end Set_Item_Init_Hook;
 768
 769    procedure Set_Item_Term_Hook (Men  : in Menu;
 770                                  Proc : in Menu_Hook_Function)
 771    is
 772       function Set_Item_Term (Men  : Menu;
 773                               Proc : Menu_Hook_Function) return C_Int;
 774       pragma Import (C, Set_Item_Term, "set_item_term");
 775
 776       Res : constant Eti_Error := Set_Item_Term (Men, Proc);
 777    begin
 778       if Res /= E_Ok then
 779          Eti_Exception (Res);
 780       end if;
 781    end Set_Item_Term_Hook;
 782
 783    procedure Set_Menu_Init_Hook (Men  : in Menu;
 784                                  Proc : in Menu_Hook_Function)
 785    is
 786       function Set_Menu_Init (Men  : Menu;
 787                               Proc : Menu_Hook_Function) return C_Int;
 788       pragma Import (C, Set_Menu_Init, "set_menu_init");
 789
 790       Res : constant Eti_Error := Set_Menu_Init (Men, Proc);
 791    begin
 792       if  Res /= E_Ok then
 793          Eti_Exception (Res);
 794       end if;
 795    end Set_Menu_Init_Hook;
 796
 797    procedure Set_Menu_Term_Hook (Men  : in Menu;
 798                                  Proc : in Menu_Hook_Function)
 799    is
 800       function Set_Menu_Term (Men  : Menu;
 801                               Proc : Menu_Hook_Function) return C_Int;
 802       pragma Import (C, Set_Menu_Term, "set_menu_term");
 803
 804       Res : constant Eti_Error := Set_Menu_Term (Men, Proc);
 805    begin
 806       if Res /= E_Ok then
 807          Eti_Exception (Res);
 808       end if;
 809    end Set_Menu_Term_Hook;
 810
 811    function Get_Item_Init_Hook (Men : Menu) return Menu_Hook_Function
 812    is
 813       function Item_Init (Men : Menu) return Menu_Hook_Function;
 814       pragma Import (C, Item_Init, "item_init");
 815    begin
 816       return Item_Init (Men);
 817    end Get_Item_Init_Hook;
 818
 819    function Get_Item_Term_Hook (Men : Menu) return Menu_Hook_Function
 820    is
 821       function Item_Term (Men : Menu) return Menu_Hook_Function;
 822       pragma Import (C, Item_Term, "item_term");
 823    begin
 824       return Item_Term (Men);
 825    end Get_Item_Term_Hook;
 826
 827    function Get_Menu_Init_Hook (Men : Menu) return Menu_Hook_Function
 828    is
 829       function Menu_Init (Men : Menu) return Menu_Hook_Function;
 830       pragma Import (C, Menu_Init, "menu_init");
 831    begin
 832       return Menu_Init (Men);
 833    end Get_Menu_Init_Hook;
 834
 835    function Get_Menu_Term_Hook (Men : Menu) return Menu_Hook_Function
 836    is
 837       function Menu_Term (Men : Menu) return Menu_Hook_Function;
 838       pragma Import (C, Menu_Term, "menu_term");
 839    begin
 840       return Menu_Term (Men);
 841    end Get_Menu_Term_Hook;
 842 -------------------------------------------------------------------------------
 843    --  This is a bit delicate if we want to manipulate an Ada created menu
 844    --  from C routines or vice versa.
 845    --  In Ada created menus we use the low level user pointer to maintain
 846    --  binding internal additional informations about the menu. This
 847    --  internal information contains a hook for the Ada provided user pointer.
 848    --  Unless you understand this implementation, the safest way in mixed
 849    --  language programs to deal with user pointers is, that only the language
 850    --  that created the menu should also manipulate the user pointer for that
 851    --  menu.
 852    procedure Redefine (Men   : in Menu;
 853                        Items : in Item_Array)
 854    is
 855       function Set_Items (Men   : Menu;
 856                           Items : Item_Array_Access) return C_Int;
 857       pragma Import (C, Set_Items, "set_menu_items");
 858
 859       function Menu_Userptr (Men : Menu) return Ada_User_Wrapper_Access;
 860       pragma Import (C, Menu_Userptr, "menu_userptr");
 861
 862       U   : Ada_User_Wrapper_Access := Menu_Userptr (Men);
 863       I   : Item_Array_Access;
 864       Res : Eti_Error;
 865    begin
 866       if U = null or else U.I = null then raise Menu_Exception;
 867       else
 868          --  create internally an array of items that contains an
 869          --  additional place for the terminating null item.
 870          I := new Item_Array (1 .. (Items'Length + 1));
 871          I.all (1 .. Items'Length) := Items (Items'First .. Items'Last);
 872          I.all (Items'Length + 1) := Null_Item;
 873          Res := Set_Items (Men, I);
 874          if  Res /= E_Ok then
 875             Free_Allocated_Items (I);
 876             Eti_Exception (Res);
 877          else
 878             Free_Allocated_Items (U.I);
 879             U.I := I;
 880          end if;
 881       end if;
 882    end Redefine;
 883
 884    function Item_Count (Men : Menu) return Natural
 885    is
 886       function Count (Men : Menu) return C_Int;
 887       pragma Import (C, Count, "item_count");
 888    begin
 889       return Natural (Count (Men));
 890    end Item_Count;
 891
 892    function Items (Men : Menu) return Item_Array_Access
 893    is
 894       function M_Items (Men : Menu) return Item_Array_Access;
 895       pragma Import (C, M_Items, "menu_items");
 896    begin
 897       return M_Items (Men);
 898    end Items;
 899
 900 -------------------------------------------------------------------------------
 901    function Create (Items : Item_Array) return Menu
 902    is
 903       function Newmenu (Items : Item_Array_Access) return Menu;
 904       pragma Import (C, Newmenu, "new_menu");
 905
 906       function Set_Menu_Userptr (Men  : Menu;
 907                                  Addr : Ada_User_Wrapper_Access)  return C_Int;
 908       pragma Import (C, Set_Menu_Userptr, "set_menu_userptr");
 909
 910       M   : Menu;
 911       I   : Item_Array_Access;
 912       U   : Ada_User_Wrapper_Access;
 913       Res : Eti_Error;
 914    begin
 915       I := new Item_Array (1 .. (Items'Length + 1));
 916       I.all (1 .. Items'Length) := Items (Items'First .. Items'Last);
 917       I.all (Items'Length + 1) := Null_Item;
 918       M := Newmenu (I);
 919       if M = Null_Menu then
 920          Free_Allocated_Items (I);
 921          raise Menu_Exception;
 922       end if;
 923       U := new Ada_User_Wrapper' (System.Null_Address, I);
 924       Res := Set_Menu_Userptr (M, U);
 925       if  Res /= E_Ok then
 926          Free_Allocated_Items (I);
 927          Free_User_Wrapper (U);
 928          Eti_Exception (Res);
 929       end if;
 930       return M;
 931    end Create;
 932
 933    procedure Delete (Men : in out Menu)
 934    is
 935       function Free (Men : Menu) return C_Int;
 936       pragma Import (C, Free, "free_menu");
 937       function Menu_Userptr (Men : Menu) return Ada_User_Wrapper_Access;
 938       pragma Import (C, Menu_Userptr, "menu_userptr");
 939
 940       U   : Ada_User_Wrapper_Access := Menu_Userptr (Men);
 941       Res : constant Eti_Error := Free (Men);
 942    begin
 943       if Res /= E_Ok then
 944          Eti_Exception (Res);
 945       end if;
 946       if U = null or else U.I = null then
 947          raise Menu_Exception;
 948       end if;
 949       Free_Allocated_Items (U.I);
 950       Free_User_Wrapper (U);
 951       Men := Null_Menu;
 952    end Delete;
 953
 954 ------------------------------------------------------------------------------
 955    function Driver (Men : Menu;
 956                     Key : Key_Code) return Driver_Result
 957    is
 958       function Driver (Men : Menu;
 959                        Key : C_Int) return C_Int;
 960       pragma Import (C, Driver, "menu_driver");
 961
 962       R : Eti_Error := Driver (Men, C_Int (Key));
 963    begin
 964       if R /= E_Ok then
 965          case R is
 966             when E_Unknown_Command  => return Unknown_Request;
 967             when E_No_Match         => return No_Match;
 968             when E_Request_Denied |
 969                  E_Not_Selectable   => return Request_Denied;
 970             when others =>
 971                Eti_Exception (R);
 972          end case;
 973       end if;
 974       return Menu_Ok;
 975    end Driver;
 976 -------------------------------------------------------------------------------
 977 begin
 978    if Generation_Bit_Order /= System.Default_Bit_Order then
 979       raise Constraint_Error;
 980    end if;
 981
 982    Default_Menu_Options  := Get_Options (Null_Menu);
 983    Default_Item_Options  := Get_Options (Null_Item);
 984 end Terminal_Interface.Curses.Menus;