Ada95/src/terminal_interface-curses-forms.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                           GNAT ncurses Binding                           --
   4 --                                                                          --
   5 --                      Terminal_Interface.Curses.Forms                     --
   6 --                                                                          --
   7 --                                 B O D Y                                  --
   8 --                                                                          --
   9 ------------------------------------------------------------------------------
  10 -- Copyright 2020 Thomas E. Dickey                                          --
  11 -- Copyright 1999-2011,2014 Free Software Foundation, Inc.                  --
  12 --                                                                          --
  13 -- Permission is hereby granted, free of charge, to any person obtaining a  --
  14 -- copy of this software and associated documentation files (the            --
  15 -- "Software"), to deal in the Software without restriction, including      --
  16 -- without limitation the rights to use, copy, modify, merge, publish,      --
  17 -- distribute, distribute with modifications, sublicense, and/or sell       --
  18 -- copies of the Software, and to permit persons to whom the Software is    --
  19 -- furnished to do so, subject to the following conditions:                 --
  20 --                                                                          --
  21 -- The above copyright notice and this permission notice shall be included  --
  22 -- in all copies or substantial portions of the Software.                   --
  23 --                                                                          --
  24 -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS  --
  25 -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF               --
  26 -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.   --
  27 -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,   --
  28 -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR    --
  29 -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR    --
  30 -- THE USE OR OTHER DEALINGS IN THE SOFTWARE.                               --
  31 --                                                                          --
  32 -- Except as contained in this notice, the name(s) of the above copyright   --
  33 -- holders shall not be used in advertising or otherwise to promote the     --
  34 -- sale, use or other dealings in this Software without prior written       --
  35 -- authorization.                                                           --
  36 ------------------------------------------------------------------------------
  37 --  Author:  Juergen Pfeifer, 1996
  38 --  Version Control:
  39 --  $Revision: 1.33 $
  40 --  $Date: 2020/02/02 23:34:34 $
  41 --  Binding Version 01.00
  42 ------------------------------------------------------------------------------
  43 with Ada.Unchecked_Deallocation;
  44
  45 with Interfaces.C; use Interfaces.C;
  46 with Interfaces.C.Strings; use Interfaces.C.Strings;
  47 with Interfaces.C.Pointers;
  48
  49 with Terminal_Interface.Curses.Aux;
  50
  51 package body Terminal_Interface.Curses.Forms is
  52
  53    use Terminal_Interface.Curses.Aux;
  54
  55    type C_Field_Array is array (Natural range <>) of aliased Field;
  56    package F_Array is new
  57      Interfaces.C.Pointers (Natural, Field, C_Field_Array, Null_Field);
  58
  59 ------------------------------------------------------------------------------
  60    --  |
  61    --  |
  62    --  |
  63    --  subtype chars_ptr is Interfaces.C.Strings.chars_ptr;
  64
  65    procedure Request_Name (Key  : Form_Request_Code;
  66                                 Name : out String)
  67    is
  68       function Form_Request_Name (Key : C_Int) return chars_ptr;
  69       pragma Import (C, Form_Request_Name, "form_request_name");
  70    begin
  71       Fill_String (Form_Request_Name (C_Int (Key)), Name);
  72    end Request_Name;
  73
  74    function Request_Name (Key : Form_Request_Code) return String
  75    is
  76       function Form_Request_Name (Key : C_Int) return chars_ptr;
  77       pragma Import (C, Form_Request_Name, "form_request_name");
  78    begin
  79       return Fill_String (Form_Request_Name (C_Int (Key)));
  80    end Request_Name;
  81 ------------------------------------------------------------------------------
  82    --  |
  83    --  |
  84    --  |
  85    --  |
  86    --  |=====================================================================
  87    --  | man page form_field_new.3x
  88    --  |=====================================================================
  89    --  |
  90    --  |
  91    --  |
  92    function Create (Height       : Line_Count;
  93                     Width        : Column_Count;
  94                     Top          : Line_Position;
  95                     Left         : Column_Position;
  96                     Off_Screen   : Natural := 0;
  97                     More_Buffers : Buffer_Number := Buffer_Number'First)
  98                     return Field
  99    is
 100       function Newfield (H, W, T, L, O, M : C_Int) return Field;
 101       pragma Import (C, Newfield, "new_field");
 102       Fld : constant Field := Newfield (C_Int (Height), C_Int (Width),
 103                                         C_Int (Top), C_Int (Left),
 104                                         C_Int (Off_Screen),
 105                                         C_Int (More_Buffers));
 106    begin
 107       if Fld = Null_Field then
 108          raise Form_Exception;
 109       end if;
 110       return Fld;
 111    end Create;
 112 --  |
 113 --  |
 114 --  |
 115    procedure Delete (Fld : in out Field)
 116    is
 117       function Free_Field (Fld : Field) return Eti_Error;
 118       pragma Import (C, Free_Field, "free_field");
 119
 120    begin
 121       Eti_Exception (Free_Field (Fld));
 122       Fld := Null_Field;
 123    end Delete;
 124    --  |
 125    --  |
 126    --  |
 127    function Duplicate (Fld  : Field;
 128                        Top  : Line_Position;
 129                        Left : Column_Position) return Field
 130    is
 131       function Dup_Field (Fld  : Field;
 132                           Top  : C_Int;
 133                           Left : C_Int) return Field;
 134       pragma Import (C, Dup_Field, "dup_field");
 135
 136       F : constant Field := Dup_Field (Fld,
 137                                        C_Int (Top),
 138                                        C_Int (Left));
 139    begin
 140       if F = Null_Field then
 141          raise Form_Exception;
 142       end if;
 143       return F;
 144    end Duplicate;
 145    --  |
 146    --  |
 147    --  |
 148    function Link (Fld  : Field;
 149                   Top  : Line_Position;
 150                   Left : Column_Position) return Field
 151    is
 152       function Lnk_Field (Fld  : Field;
 153                           Top  : C_Int;
 154                           Left : C_Int) return Field;
 155       pragma Import (C, Lnk_Field, "link_field");
 156
 157       F : constant Field := Lnk_Field (Fld,
 158                                        C_Int (Top),
 159                                        C_Int (Left));
 160    begin
 161       if F = Null_Field then
 162          raise Form_Exception;
 163       end if;
 164       return F;
 165    end Link;
 166    --  |
 167    --  |=====================================================================
 168    --  | man page form_field_just.3x
 169    --  |=====================================================================
 170    --  |
 171    --  |
 172    --  |
 173    procedure Set_Justification (Fld  : Field;
 174                                 Just : Field_Justification := None)
 175    is
 176       function Set_Field_Just (Fld  : Field;
 177                                Just : C_Int) return Eti_Error;
 178       pragma Import (C, Set_Field_Just, "set_field_just");
 179
 180    begin
 181       Eti_Exception (Set_Field_Just (Fld,
 182                                      C_Int (Field_Justification'Pos (Just))));
 183    end Set_Justification;
 184    --  |
 185    --  |
 186    --  |
 187    function Get_Justification (Fld : Field) return Field_Justification
 188    is
 189       function Field_Just (Fld : Field) return C_Int;
 190       pragma Import (C, Field_Just, "field_just");
 191    begin
 192       return Field_Justification'Val (Field_Just (Fld));
 193    end Get_Justification;
 194    --  |
 195    --  |=====================================================================
 196    --  | man page form_field_buffer.3x
 197    --  |=====================================================================
 198    --  |
 199    --  |
 200    --  |
 201    procedure Set_Buffer
 202      (Fld    : Field;
 203       Buffer : Buffer_Number := Buffer_Number'First;
 204       Str    : String)
 205    is
 206       function Set_Fld_Buffer (Fld    : Field;
 207                                  Bufnum : C_Int;
 208                                  S      : char_array)
 209         return Eti_Error;
 210       pragma Import (C, Set_Fld_Buffer, "set_field_buffer");
 211
 212    begin
 213       Eti_Exception (Set_Fld_Buffer (Fld, C_Int (Buffer), To_C (Str)));
 214    end Set_Buffer;
 215    --  |
 216    --  |
 217    --  |
 218    procedure Get_Buffer
 219      (Fld    : Field;
 220       Buffer : Buffer_Number := Buffer_Number'First;
 221       Str    : out String)
 222    is
 223       function Field_Buffer (Fld : Field;
 224                              B   : C_Int) return chars_ptr;
 225       pragma Import (C, Field_Buffer, "field_buffer");
 226    begin
 227       Fill_String (Field_Buffer (Fld, C_Int (Buffer)), Str);
 228    end Get_Buffer;
 229
 230    function Get_Buffer
 231      (Fld    : Field;
 232       Buffer : Buffer_Number := Buffer_Number'First) return String
 233    is
 234       function Field_Buffer (Fld : Field;
 235                              B   : C_Int) return chars_ptr;
 236       pragma Import (C, Field_Buffer, "field_buffer");
 237    begin
 238       return Fill_String (Field_Buffer (Fld, C_Int (Buffer)));
 239    end Get_Buffer;
 240    --  |
 241    --  |
 242    --  |
 243    procedure Set_Status (Fld    : Field;
 244                          Status : Boolean := True)
 245    is
 246       function Set_Fld_Status (Fld : Field;
 247                                St  : C_Int) return Eti_Error;
 248       pragma Import (C, Set_Fld_Status, "set_field_status");
 249
 250    begin
 251       if Set_Fld_Status (Fld, Boolean'Pos (Status)) /= E_Ok then
 252          raise Form_Exception;
 253       end if;
 254    end Set_Status;
 255    --  |
 256    --  |
 257    --  |
 258    function Changed (Fld : Field) return Boolean
 259    is
 260       function Field_Status (Fld : Field) return C_Int;
 261       pragma Import (C, Field_Status, "field_status");
 262
 263       Res : constant C_Int := Field_Status (Fld);
 264    begin
 265       if Res = Curses_False then
 266          return False;
 267       else
 268          return True;
 269       end if;
 270    end Changed;
 271    --  |
 272    --  |
 273    --  |
 274    procedure Set_Maximum_Size (Fld : Field;
 275                                Max : Natural := 0)
 276    is
 277       function Set_Field_Max (Fld : Field;
 278                               M   : C_Int) return Eti_Error;
 279       pragma Import (C, Set_Field_Max, "set_max_field");
 280
 281    begin
 282       Eti_Exception (Set_Field_Max (Fld, C_Int (Max)));
 283    end Set_Maximum_Size;
 284    --  |
 285    --  |=====================================================================
 286    --  | man page form_field_opts.3x
 287    --  |=====================================================================
 288    --  |
 289    --  |
 290    --  |
 291    procedure Set_Options (Fld     : Field;
 292                           Options : Field_Option_Set)
 293    is
 294       function Set_Field_Opts (Fld : Field;
 295                                Opt : Field_Option_Set) return Eti_Error;
 296       pragma Import (C, Set_Field_Opts, "set_field_opts");
 297
 298    begin
 299       Eti_Exception (Set_Field_Opts (Fld, Options));
 300    end Set_Options;
 301    --  |
 302    --  |
 303    --  |
 304    procedure Switch_Options (Fld     : Field;
 305                              Options : Field_Option_Set;
 306                              On      : Boolean := True)
 307    is
 308       function Field_Opts_On (Fld : Field;
 309                               Opt : Field_Option_Set) return Eti_Error;
 310       pragma Import (C, Field_Opts_On, "field_opts_on");
 311       function Field_Opts_Off (Fld : Field;
 312                                Opt : Field_Option_Set) return Eti_Error;
 313       pragma Import (C, Field_Opts_Off, "field_opts_off");
 314
 315    begin
 316       if On then
 317          Eti_Exception (Field_Opts_On (Fld, Options));
 318       else
 319          Eti_Exception (Field_Opts_Off (Fld, Options));
 320       end if;
 321    end Switch_Options;
 322    --  |
 323    --  |
 324    --  |
 325    procedure Get_Options (Fld     : Field;
 326                           Options : out Field_Option_Set)
 327    is
 328       function Field_Opts (Fld : Field) return Field_Option_Set;
 329       pragma Import (C, Field_Opts, "field_opts");
 330
 331    begin
 332       Options := Field_Opts (Fld);
 333    end Get_Options;
 334    --  |
 335    --  |
 336    --  |
 337    function Get_Options (Fld : Field := Null_Field)
 338                          return Field_Option_Set
 339    is
 340       Fos : Field_Option_Set;
 341    begin
 342       Get_Options (Fld, Fos);
 343       return Fos;
 344    end Get_Options;
 345    --  |
 346    --  |=====================================================================
 347    --  | man page form_field_attributes.3x
 348    --  |=====================================================================
 349    --  |
 350    --  |
 351    --  |
 352    procedure Set_Foreground
 353      (Fld   : Field;
 354       Fore  : Character_Attribute_Set := Normal_Video;
 355       Color : Color_Pair := Color_Pair'First)
 356    is
 357       function Set_Field_Fore (Fld  : Field;
 358                                Attr : Attributed_Character) return Eti_Error;
 359       pragma Import (C, Set_Field_Fore, "set_field_fore");
 360
 361    begin
 362       Eti_Exception (Set_Field_Fore (Fld, (Ch    => Character'First,
 363                                            Color => Color,
 364                                            Attr  => Fore)));
 365    end Set_Foreground;
 366    --  |
 367    --  |
 368    --  |
 369    procedure Foreground (Fld  : Field;
 370                          Fore : out Character_Attribute_Set)
 371    is
 372       function Field_Fore (Fld : Field) return Attributed_Character;
 373       pragma Import (C, Field_Fore, "field_fore");
 374    begin
 375       Fore := Field_Fore (Fld).Attr;
 376    end Foreground;
 377
 378    procedure Foreground (Fld   : Field;
 379                          Fore  : out Character_Attribute_Set;
 380                          Color : out Color_Pair)
 381    is
 382       function Field_Fore (Fld : Field) return Attributed_Character;
 383       pragma Import (C, Field_Fore, "field_fore");
 384    begin
 385       Fore  := Field_Fore (Fld).Attr;
 386       Color := Field_Fore (Fld).Color;
 387    end Foreground;
 388    --  |
 389    --  |
 390    --  |
 391    procedure Set_Background
 392      (Fld   : Field;
 393       Back  : Character_Attribute_Set := Normal_Video;
 394       Color : Color_Pair := Color_Pair'First)
 395    is
 396       function Set_Field_Back (Fld  : Field;
 397                                Attr : Attributed_Character) return Eti_Error;
 398       pragma Import (C, Set_Field_Back, "set_field_back");
 399
 400    begin
 401       Eti_Exception (Set_Field_Back (Fld, (Ch    => Character'First,
 402                                            Color => Color,
 403                                            Attr  => Back)));
 404    end Set_Background;
 405    --  |
 406    --  |
 407    --  |
 408    procedure Background (Fld  : Field;
 409                          Back : out Character_Attribute_Set)
 410    is
 411       function Field_Back (Fld : Field) return Attributed_Character;
 412       pragma Import (C, Field_Back, "field_back");
 413    begin
 414       Back := Field_Back (Fld).Attr;
 415    end Background;
 416
 417    procedure Background (Fld   : Field;
 418                          Back  : out Character_Attribute_Set;
 419                          Color : out Color_Pair)
 420    is
 421       function Field_Back (Fld : Field) return Attributed_Character;
 422       pragma Import (C, Field_Back, "field_back");
 423    begin
 424       Back  := Field_Back (Fld).Attr;
 425       Color := Field_Back (Fld).Color;
 426    end Background;
 427    --  |
 428    --  |
 429    --  |
 430    procedure Set_Pad_Character (Fld : Field;
 431                                 Pad : Character := Space)
 432    is
 433       function Set_Field_Pad (Fld : Field;
 434                               Ch  : C_Int) return Eti_Error;
 435       pragma Import (C, Set_Field_Pad, "set_field_pad");
 436
 437    begin
 438       Eti_Exception (Set_Field_Pad (Fld,
 439                                     C_Int (Character'Pos (Pad))));
 440    end Set_Pad_Character;
 441    --  |
 442    --  |
 443    --  |
 444    procedure Pad_Character (Fld : Field;
 445                             Pad : out Character)
 446    is
 447       function Field_Pad (Fld : Field) return C_Int;
 448       pragma Import (C, Field_Pad, "field_pad");
 449    begin
 450       Pad := Character'Val (Field_Pad (Fld));
 451    end Pad_Character;
 452    --  |
 453    --  |=====================================================================
 454    --  | man page form_field_info.3x
 455    --  |=====================================================================
 456    --  |
 457    --  |
 458    --  |
 459    procedure Info (Fld                : Field;
 460                    Lines              : out Line_Count;
 461                    Columns            : out Column_Count;
 462                    First_Row          : out Line_Position;
 463                    First_Column       : out Column_Position;
 464                    Off_Screen         : out Natural;
 465                    Additional_Buffers : out Buffer_Number)
 466    is
 467       type C_Int_Access is access all C_Int;
 468       function Fld_Info (Fld : Field;
 469                          L, C, Fr, Fc, Os, Ab : C_Int_Access)
 470                          return Eti_Error;
 471       pragma Import (C, Fld_Info, "field_info");
 472
 473       L, C, Fr, Fc, Os, Ab : aliased C_Int;
 474    begin
 475       Eti_Exception (Fld_Info (Fld,
 476                                L'Access, C'Access,
 477                                Fr'Access, Fc'Access,
 478                                Os'Access, Ab'Access));
 479       Lines              := Line_Count (L);
 480       Columns            := Column_Count (C);
 481       First_Row          := Line_Position (Fr);
 482       First_Column       := Column_Position (Fc);
 483       Off_Screen         := Natural (Os);
 484       Additional_Buffers := Buffer_Number (Ab);
 485    end Info;
 486 --  |
 487 --  |
 488 --  |
 489    procedure Dynamic_Info (Fld     : Field;
 490                            Lines   : out Line_Count;
 491                            Columns : out Column_Count;
 492                            Max     : out Natural)
 493    is
 494       type C_Int_Access is access all C_Int;
 495       function Dyn_Info (Fld : Field; L, C, M : C_Int_Access) return Eti_Error;
 496       pragma Import (C, Dyn_Info, "dynamic_field_info");
 497
 498       L, C, M : aliased C_Int;
 499    begin
 500       Eti_Exception (Dyn_Info (Fld,
 501                                L'Access, C'Access,
 502                                M'Access));
 503       Lines   := Line_Count (L);
 504       Columns := Column_Count (C);
 505       Max     := Natural (M);
 506    end Dynamic_Info;
 507    --  |
 508    --  |=====================================================================
 509    --  | man page form_win.3x
 510    --  |=====================================================================
 511    --  |
 512    --  |
 513    --  |
 514    procedure Set_Window (Frm : Form;
 515                          Win : Window)
 516    is
 517       function Set_Form_Win (Frm : Form;
 518                              Win : Window) return Eti_Error;
 519       pragma Import (C, Set_Form_Win, "set_form_win");
 520
 521    begin
 522       Eti_Exception (Set_Form_Win (Frm, Win));
 523    end Set_Window;
 524    --  |
 525    --  |
 526    --  |
 527    function Get_Window (Frm : Form) return Window
 528    is
 529       function Form_Win (Frm : Form) return Window;
 530       pragma Import (C, Form_Win, "form_win");
 531
 532       W : constant Window := Form_Win (Frm);
 533    begin
 534       return W;
 535    end Get_Window;
 536    --  |
 537    --  |
 538    --  |
 539    procedure Set_Sub_Window (Frm : Form;
 540                              Win : Window)
 541    is
 542       function Set_Form_Sub (Frm : Form;
 543                              Win : Window) return Eti_Error;
 544       pragma Import (C, Set_Form_Sub, "set_form_sub");
 545
 546    begin
 547       Eti_Exception (Set_Form_Sub (Frm, Win));
 548    end Set_Sub_Window;
 549    --  |
 550    --  |
 551    --  |
 552    function Get_Sub_Window (Frm : Form) return Window
 553    is
 554       function Form_Sub (Frm : Form) return Window;
 555       pragma Import (C, Form_Sub, "form_sub");
 556
 557       W : constant Window := Form_Sub (Frm);
 558    begin
 559       return W;
 560    end Get_Sub_Window;
 561    --  |
 562    --  |
 563    --  |
 564    procedure Scale (Frm     : Form;
 565                     Lines   : out Line_Count;
 566                     Columns : out Column_Count)
 567    is
 568       type C_Int_Access is access all C_Int;
 569       function M_Scale (Frm : Form; Yp, Xp : C_Int_Access) return Eti_Error;
 570       pragma Import (C, M_Scale, "scale_form");
 571
 572       X, Y : aliased C_Int;
 573    begin
 574       Eti_Exception (M_Scale (Frm, Y'Access, X'Access));
 575       Lines   := Line_Count (Y);
 576       Columns := Column_Count (X);
 577    end Scale;
 578    --  |
 579    --  |=====================================================================
 580    --  | man page menu_hook.3x
 581    --  |=====================================================================
 582    --  |
 583    --  |
 584    --  |
 585    procedure Set_Field_Init_Hook (Frm  : Form;
 586                                   Proc : Form_Hook_Function)
 587    is
 588       function Set_Field_Init (Frm  : Form;
 589                                Proc : Form_Hook_Function) return Eti_Error;
 590       pragma Import (C, Set_Field_Init, "set_field_init");
 591
 592    begin
 593       Eti_Exception (Set_Field_Init (Frm, Proc));
 594    end Set_Field_Init_Hook;
 595    --  |
 596    --  |
 597    --  |
 598    procedure Set_Field_Term_Hook (Frm  : Form;
 599                                   Proc : Form_Hook_Function)
 600    is
 601       function Set_Field_Term (Frm  : Form;
 602                                Proc : Form_Hook_Function) return Eti_Error;
 603       pragma Import (C, Set_Field_Term, "set_field_term");
 604
 605    begin
 606       Eti_Exception (Set_Field_Term (Frm, Proc));
 607    end Set_Field_Term_Hook;
 608    --  |
 609    --  |
 610    --  |
 611    procedure Set_Form_Init_Hook (Frm  : Form;
 612                                  Proc : Form_Hook_Function)
 613    is
 614       function Set_Form_Init (Frm  : Form;
 615                               Proc : Form_Hook_Function) return Eti_Error;
 616       pragma Import (C, Set_Form_Init, "set_form_init");
 617
 618    begin
 619       Eti_Exception (Set_Form_Init (Frm, Proc));
 620    end Set_Form_Init_Hook;
 621    --  |
 622    --  |
 623    --  |
 624    procedure Set_Form_Term_Hook (Frm  : Form;
 625                                  Proc : Form_Hook_Function)
 626    is
 627       function Set_Form_Term (Frm  : Form;
 628                               Proc : Form_Hook_Function) return Eti_Error;
 629       pragma Import (C, Set_Form_Term, "set_form_term");
 630
 631    begin
 632       Eti_Exception (Set_Form_Term (Frm, Proc));
 633    end Set_Form_Term_Hook;
 634    --  |
 635    --  |=====================================================================
 636    --  | man page form_fields.3x
 637    --  |=====================================================================
 638    --  |
 639    --  |
 640    --  |
 641    procedure Redefine (Frm  : Form;
 642                        Flds : Field_Array_Access)
 643    is
 644       function Set_Frm_Fields (Frm   : Form;
 645                                Items : System.Address) return Eti_Error;
 646       pragma Import (C, Set_Frm_Fields, "set_form_fields");
 647
 648    begin
 649       pragma Assert (Flds.all (Flds'Last) = Null_Field);
 650       if Flds.all (Flds'Last) /= Null_Field then
 651          raise Form_Exception;
 652       else
 653          Eti_Exception (Set_Frm_Fields (Frm, Flds.all (Flds'First)'Address));
 654       end if;
 655    end Redefine;
 656    --  |
 657    --  |
 658    --  |
 659    function Fields (Frm   : Form;
 660                     Index : Positive) return Field
 661    is
 662       use F_Array;
 663
 664       function C_Fields (Frm : Form) return Pointer;
 665       pragma Import (C, C_Fields, "form_fields");
 666
 667       P : Pointer := C_Fields (Frm);
 668    begin
 669       if P = null or else Index > Field_Count (Frm) then
 670          raise Form_Exception;
 671       else
 672          P := P + ptrdiff_t (C_Int (Index) - 1);
 673          return P.all;
 674       end if;
 675    end Fields;
 676    --  |
 677    --  |
 678    --  |
 679    function Field_Count (Frm : Form) return Natural
 680    is
 681       function Count (Frm : Form) return C_Int;
 682       pragma Import (C, Count, "field_count");
 683    begin
 684       return Natural (Count (Frm));
 685    end Field_Count;
 686    --  |
 687    --  |
 688    --  |
 689    procedure Move (Fld    : Field;
 690                    Line   : Line_Position;
 691                    Column : Column_Position)
 692    is
 693       function Move (Fld : Field; L, C : C_Int) return Eti_Error;
 694       pragma Import (C, Move, "move_field");
 695
 696    begin
 697       Eti_Exception (Move (Fld, C_Int (Line), C_Int (Column)));
 698    end Move;
 699    --  |
 700    --  |=====================================================================
 701    --  | man page form_new.3x
 702    --  |=====================================================================
 703    --  |
 704    --  |
 705    --  |
 706    function Create (Fields : Field_Array_Access) return Form
 707    is
 708       function NewForm (Fields : System.Address) return Form;
 709       pragma Import (C, NewForm, "new_form");
 710
 711       M   : Form;
 712    begin
 713       pragma Assert (Fields.all (Fields'Last) = Null_Field);
 714       if Fields.all (Fields'Last) /= Null_Field then
 715          raise Form_Exception;
 716       else
 717          M := NewForm (Fields.all (Fields'First)'Address);
 718          if M = Null_Form then
 719             raise Form_Exception;
 720          end if;
 721          return M;
 722       end if;
 723    end Create;
 724    --  |
 725    --  |
 726    --  |
 727    procedure Delete (Frm : in out Form)
 728    is
 729       function Free (Frm : Form) return Eti_Error;
 730       pragma Import (C, Free, "free_form");
 731
 732    begin
 733       Eti_Exception (Free (Frm));
 734       Frm := Null_Form;
 735    end Delete;
 736    --  |
 737    --  |=====================================================================
 738    --  | man page form_opts.3x
 739    --  |=====================================================================
 740    --  |
 741    --  |
 742    --  |
 743    procedure Set_Options (Frm     : Form;
 744                           Options : Form_Option_Set)
 745    is
 746       function Set_Form_Opts (Frm : Form;
 747                               Opt : Form_Option_Set) return Eti_Error;
 748       pragma Import (C, Set_Form_Opts, "set_form_opts");
 749
 750    begin
 751       Eti_Exception (Set_Form_Opts (Frm, Options));
 752    end Set_Options;
 753    --  |
 754    --  |
 755    --  |
 756    procedure Switch_Options (Frm     : Form;
 757                              Options : Form_Option_Set;
 758                              On      : Boolean := True)
 759    is
 760       function Form_Opts_On (Frm : Form;
 761                              Opt : Form_Option_Set) return Eti_Error;
 762       pragma Import (C, Form_Opts_On, "form_opts_on");
 763       function Form_Opts_Off (Frm : Form;
 764                               Opt : Form_Option_Set) return Eti_Error;
 765       pragma Import (C, Form_Opts_Off, "form_opts_off");
 766
 767    begin
 768       if On then
 769          Eti_Exception (Form_Opts_On (Frm, Options));
 770       else
 771          Eti_Exception (Form_Opts_Off (Frm, Options));
 772       end if;
 773    end Switch_Options;
 774    --  |
 775    --  |
 776    --  |
 777    procedure Get_Options (Frm     : Form;
 778                           Options : out Form_Option_Set)
 779    is
 780       function Form_Opts (Frm : Form) return Form_Option_Set;
 781       pragma Import (C, Form_Opts, "form_opts");
 782
 783    begin
 784       Options := Form_Opts (Frm);
 785    end Get_Options;
 786    --  |
 787    --  |
 788    --  |
 789    function Get_Options (Frm : Form := Null_Form) return Form_Option_Set
 790    is
 791       Fos : Form_Option_Set;
 792    begin
 793       Get_Options (Frm, Fos);
 794       return Fos;
 795    end Get_Options;
 796    --  |
 797    --  |=====================================================================
 798    --  | man page form_post.3x
 799    --  |=====================================================================
 800    --  |
 801    --  |
 802    --  |
 803    procedure Post (Frm  : Form;
 804                    Post : Boolean := True)
 805    is
 806       function M_Post (Frm : Form) return Eti_Error;
 807       pragma Import (C, M_Post, "post_form");
 808       function M_Unpost (Frm : Form) return Eti_Error;
 809       pragma Import (C, M_Unpost, "unpost_form");
 810
 811    begin
 812       if Post then
 813          Eti_Exception (M_Post (Frm));
 814       else
 815          Eti_Exception (M_Unpost (Frm));
 816       end if;
 817    end Post;
 818    --  |
 819    --  |=====================================================================
 820    --  | man page form_cursor.3x
 821    --  |=====================================================================
 822    --  |
 823    --  |
 824    --  |
 825    procedure Position_Cursor (Frm : Form)
 826    is
 827       function Pos_Form_Cursor (Frm : Form) return Eti_Error;
 828       pragma Import (C, Pos_Form_Cursor, "pos_form_cursor");
 829
 830    begin
 831       Eti_Exception (Pos_Form_Cursor (Frm));
 832    end Position_Cursor;
 833    --  |
 834    --  |=====================================================================
 835    --  | man page form_data.3x
 836    --  |=====================================================================
 837    --  |
 838    --  |
 839    --  |
 840    function Data_Ahead (Frm : Form) return Boolean
 841    is
 842       function Ahead (Frm : Form) return C_Int;
 843       pragma Import (C, Ahead, "data_ahead");
 844
 845       Res : constant C_Int := Ahead (Frm);
 846    begin
 847       if Res = Curses_False then
 848          return False;
 849       else
 850          return True;
 851       end if;
 852    end Data_Ahead;
 853    --  |
 854    --  |
 855    --  |
 856    function Data_Behind (Frm : Form) return Boolean
 857    is
 858       function Behind (Frm : Form) return C_Int;
 859       pragma Import (C, Behind, "data_behind");
 860
 861       Res : constant C_Int := Behind (Frm);
 862    begin
 863       if Res = Curses_False then
 864          return False;
 865       else
 866          return True;
 867       end if;
 868    end Data_Behind;
 869    --  |
 870    --  |=====================================================================
 871    --  | man page form_driver.3x
 872    --  |=====================================================================
 873    --  |
 874    --  |
 875    --  |
 876    function Driver (Frm : Form;
 877                     Key : Key_Code) return Driver_Result
 878    is
 879       function Frm_Driver (Frm : Form; Key : C_Int) return Eti_Error;
 880       pragma Import (C, Frm_Driver, "form_driver");
 881
 882       R : constant Eti_Error := Frm_Driver (Frm, C_Int (Key));
 883    begin
 884       case R is
 885          when E_Unknown_Command =>
 886             return Unknown_Request;
 887          when E_Invalid_Field =>
 888             return Invalid_Field;
 889          when E_Request_Denied =>
 890             return Request_Denied;
 891          when others =>
 892             Eti_Exception (R);
 893             return Form_Ok;
 894       end case;
 895    end Driver;
 896    --  |
 897    --  |=====================================================================
 898    --  | man page form_page.3x
 899    --  |=====================================================================
 900    --  |
 901    --  |
 902    --  |
 903    procedure Set_Current (Frm : Form;
 904                           Fld : Field)
 905    is
 906       function Set_Current_Fld (Frm : Form; Fld : Field) return Eti_Error;
 907       pragma Import (C, Set_Current_Fld, "set_current_field");
 908
 909    begin
 910       Eti_Exception (Set_Current_Fld (Frm, Fld));
 911    end Set_Current;
 912    --  |
 913    --  |
 914    --  |
 915    function Current (Frm : Form) return Field
 916    is
 917       function Current_Fld (Frm : Form) return Field;
 918       pragma Import (C, Current_Fld, "current_field");
 919
 920       Fld : constant Field := Current_Fld (Frm);
 921    begin
 922       if Fld = Null_Field then
 923          raise Form_Exception;
 924       end if;
 925       return Fld;
 926    end Current;
 927    --  |
 928    --  |
 929    --  |
 930    procedure Set_Page (Frm  : Form;
 931                        Page : Page_Number := Page_Number'First)
 932    is
 933       function Set_Frm_Page (Frm : Form; Pg : C_Int) return Eti_Error;
 934       pragma Import (C, Set_Frm_Page, "set_form_page");
 935
 936    begin
 937       Eti_Exception (Set_Frm_Page (Frm, C_Int (Page)));
 938    end Set_Page;
 939    --  |
 940    --  |
 941    --  |
 942    function Page (Frm : Form) return Page_Number
 943    is
 944       function Get_Page (Frm : Form) return C_Int;
 945       pragma Import (C, Get_Page, "form_page");
 946
 947       P : constant C_Int := Get_Page (Frm);
 948    begin
 949       if P < 0 then
 950          raise Form_Exception;
 951       else
 952          return Page_Number (P);
 953       end if;
 954    end Page;
 955
 956    function Get_Index (Fld : Field) return Positive
 957    is
 958       function Get_Fieldindex (Fld : Field) return C_Int;
 959       pragma Import (C, Get_Fieldindex, "field_index");
 960
 961       Res : constant C_Int := Get_Fieldindex (Fld);
 962    begin
 963       if Res = Curses_Err then
 964          raise Form_Exception;
 965       end if;
 966       return Positive (Natural (Res) + Positive'First);
 967    end Get_Index;
 968
 969    --  |
 970    --  |=====================================================================
 971    --  | man page form_new_page.3x
 972    --  |=====================================================================
 973    --  |
 974    --  |
 975    --  |
 976    procedure Set_New_Page (Fld      : Field;
 977                            New_Page : Boolean := True)
 978    is
 979       function Set_Page (Fld : Field; Flg : C_Int) return Eti_Error;
 980       pragma Import (C, Set_Page, "set_new_page");
 981
 982    begin
 983       Eti_Exception (Set_Page (Fld, Boolean'Pos (New_Page)));
 984    end Set_New_Page;
 985    --  |
 986    --  |
 987    --  |
 988    function Is_New_Page (Fld : Field) return Boolean
 989    is
 990       function Is_New (Fld : Field) return C_Int;
 991       pragma Import (C, Is_New, "new_page");
 992
 993       Res : constant C_Int := Is_New (Fld);
 994    begin
 995       if Res = Curses_False then
 996          return False;
 997       else
 998          return True;
 999       end if;
1000    end Is_New_Page;
1001
1002    procedure Free (FA          : in out Field_Array_Access;
1003                    Free_Fields : Boolean := False)
1004    is
1005       procedure Release is new Ada.Unchecked_Deallocation
1006         (Field_Array, Field_Array_Access);
1007    begin
1008       if FA /= null and then Free_Fields then
1009          for I in FA'First .. (FA'Last - 1) loop
1010             if FA.all (I) /= Null_Field then
1011                Delete (FA.all (I));
1012             end if;
1013          end loop;
1014       end if;
1015       Release (FA);
1016    end Free;
1017
1018    --  |=====================================================================
1019
1020    function Default_Field_Options return Field_Option_Set
1021    is
1022    begin
1023       return Get_Options (Null_Field);
1024    end Default_Field_Options;
1025
1026    function Default_Form_Options return Form_Option_Set
1027    is
1028    begin
1029       return Get_Options (Null_Form);
1030    end Default_Form_Options;
1031
1032 end Terminal_Interface.Curses.Forms;