gcc/ada/g-tty.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                             G N A T . T T Y                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 2002-2011, AdaCore                     --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Interfaces.C.Strings; use Interfaces.C.Strings;
  33
  34 package body GNAT.TTY is
  35
  36    use System;
  37
  38    procedure Check_TTY (Handle : TTY_Handle);
  39    --  Check the validity of Handle. Raise Program_Error if ttys are not
  40    --  supported. Raise Constraint_Error if Handle is an invalid handle.
  41
  42    ------------------
  43    -- Allocate_TTY --
  44    ------------------
  45
  46    procedure Allocate_TTY (Handle : out TTY_Handle) is
  47       function Internal return System.Address;
  48       pragma Import (C, Internal, "__gnat_new_tty");
  49
  50    begin
  51       if not TTY_Supported then
  52          raise Program_Error;
  53       end if;
  54
  55       Handle.Handle := Internal;
  56    end Allocate_TTY;
  57
  58    ---------------
  59    -- Check_TTY --
  60    ---------------
  61
  62    procedure Check_TTY (Handle : TTY_Handle) is
  63    begin
  64       if not TTY_Supported then
  65          raise Program_Error;
  66       elsif Handle.Handle = System.Null_Address then
  67          raise Constraint_Error;
  68       end if;
  69    end Check_TTY;
  70
  71    ---------------
  72    -- Close_TTY --
  73    ---------------
  74
  75    procedure Close_TTY (Handle : in out TTY_Handle) is
  76       procedure Internal (Handle : System.Address);
  77       pragma Import (C, Internal, "__gnat_close_tty");
  78    begin
  79       Check_TTY (Handle);
  80       Internal (Handle.Handle);
  81       Handle.Handle := System.Null_Address;
  82    end Close_TTY;
  83
  84    ---------------
  85    -- Reset_TTY --
  86    ---------------
  87
  88    procedure Reset_TTY (Handle : TTY_Handle) is
  89       procedure Internal (Handle : System.Address);
  90       pragma Import (C, Internal, "__gnat_reset_tty");
  91    begin
  92       Check_TTY (Handle);
  93       Internal (Handle.Handle);
  94    end Reset_TTY;
  95
  96    --------------------
  97    -- TTY_Descriptor --
  98    --------------------
  99
 100    function TTY_Descriptor
 101      (Handle : TTY_Handle) return GNAT.OS_Lib.File_Descriptor
 102    is
 103       function Internal
 104         (Handle : System.Address) return GNAT.OS_Lib.File_Descriptor;
 105       pragma Import (C, Internal, "__gnat_tty_fd");
 106    begin
 107       Check_TTY (Handle);
 108       return Internal (Handle.Handle);
 109    end TTY_Descriptor;
 110
 111    --------------
 112    -- TTY_Name --
 113    --------------
 114
 115    function TTY_Name (Handle : TTY_Handle) return String is
 116       function Internal (Handle : System.Address) return chars_ptr;
 117       pragma Import (C, Internal, "__gnat_tty_name");
 118    begin
 119       Check_TTY (Handle);
 120       return Value (Internal (Handle.Handle));
 121    end TTY_Name;
 122
 123    -------------------
 124    -- TTY_Supported --
 125    -------------------
 126
 127    function TTY_Supported return Boolean is
 128       function Internal return Integer;
 129       pragma Import (C, Internal, "__gnat_tty_supported");
 130    begin
 131       return Internal /= 0;
 132    end TTY_Supported;
 133
 134 end GNAT.TTY;