Initial revision

2 files changed, 877 insertions, 0 deletions

diff --git a/src/floatfns.c b/src/floatfns.c
new file mode 100644
index 00000000000..1cf132d5f5c
--- /dev/null
+++ b/src/floatfns.c
@@ -0,0 +1,558 @@
+/* Primitive operations on floating point for GNU Emacs Lisp interpreter.
+   Copyright (C) 1988 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 1, or (at your option)
+any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs; see the file COPYING.  If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
+
+
+#include <signal.h>
+
+#include "config.h"
+#include "lisp.h"
+
+Lisp_Object Qarith_error;
+
+#ifdef LISP_FLOAT_TYPE
+#include <math.h>
+
+/* Nonzero while executing in floating point.
+   This tells float_error what to do.  */
+
+static int in_float;
+
+/* If an argument is out of range for a mathematical function,
+   that is detected with a signal.  Here is the actual argument
+   value to use in the error message.  */
+
+static Lisp_Object float_error_arg;
+
+#define IN_FLOAT(d, num) \
+(in_float = 1, float_error_arg = num, (d), in_float = 0)
+
+/* Extract a Lisp number as a `double', or signal an error.  */
+
+double
+extract_float (num)
+     Lisp_Object num;
+{
+  CHECK_NUMBER_OR_FLOAT (num, 0);
+
+  if (XTYPE (num) == Lisp_Float)
+    return XFLOAT (num)->data;
+  return (double) XINT (num);
+}
+
+DEFUN ("acos", Facos, Sacos, 1, 1, 0,
+  "Return the inverse cosine of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = acos (d), num);
+  return make_float (d);
+}
+
+DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0,
+  "Return the inverse hyperbolic cosine of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = acosh (d), num);
+  return make_float (d);
+}
+
+DEFUN ("asin", Fasin, Sasin, 1, 1, 0,
+  "Return the inverse sine of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = asin (d), num);
+  return make_float (d);
+}
+
+DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0,
+  "Return the inverse hyperbolic sine of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = asinh (d), num);
+  return make_float (d);
+}
+
+DEFUN ("atan", Fatan, Satan, 1, 1, 0,
+  "Return the inverse tangent of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = atan (d), num);
+  return make_float (d);
+}
+
+DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0,
+  "Return the inverse hyperbolic tangent of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = atanh (d), num);
+  return make_float (d);
+}
+
+DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0,
+  "Return the bessel function j0 of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = j0 (d), num);
+  return make_float (d);
+}
+
+DEFUN ("bessel-j1", Fbessel_j1, Sbessel_j1, 1, 1, 0,
+  "Return the bessel function j1 of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = j1 (d), num);
+  return make_float (d);
+}
+
+DEFUN ("bessel-jn", Fbessel_jn, Sbessel_jn, 2, 2, 0,
+  "Return the order N bessel function output jn of ARG.\n\
+The first arg (the order) is truncated to an integer.")
+  (num1, num2)
+     register Lisp_Object num1, num2;
+{
+  int i1 = extract_float (num1);
+  double f2 = extract_float (num2);
+
+  IN_FLOAT (f2 = jn (i1, f2), num1);
+  return make_float (f2);
+}
+
+DEFUN ("bessel-y0", Fbessel_y0, Sbessel_y0, 1, 1, 0,
+  "Return the bessel function y0 of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = y0 (d), num);
+  return make_float (d);
+}
+
+DEFUN ("bessel-y1", Fbessel_y1, Sbessel_y1, 1, 1, 0,
+  "Return the bessel function y1 of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = y1 (d), num);
+  return make_float (d);
+}
+
+DEFUN ("bessel-yn", Fbessel_yn, Sbessel_yn, 2, 2, 0,
+  "Return the order N bessel function output yn of ARG.\n\
+The first arg (the order) is truncated to an integer.")
+  (num1, num2)
+     register Lisp_Object num1, num2;
+{
+  int i1 = extract_float (num1);
+  double f2 = extract_float (num2);
+
+  IN_FLOAT (f2 = yn (i1, f2), num1);
+  return make_float (f2);
+}
+
+DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0,
+  "Return the cube root of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = cbrt (d), num);
+  return make_float (d);
+}
+
+DEFUN ("cos", Fcos, Scos, 1, 1, 0,
+  "Return the cosine of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = cos (d), num);
+  return make_float (d);
+}
+
+DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0,
+  "Return the hyperbolic cosine of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = cosh (d), num);
+  return make_float (d);
+}
+
+DEFUN ("erf", Ferf, Serf, 1, 1, 0,
+  "Return the mathematical error function of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = erf (d), num);
+  return make_float (d);
+}
+
+DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0,
+  "Return the complementary error function of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = erfc (d), num);
+  return make_float (d);
+}
+
+DEFUN ("exp", Fexp, Sexp, 1, 1, 0,
+  "Return the exponential base e of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = exp (d), num);
+  return make_float (d);
+}
+
+DEFUN ("expm1", Fexpm1, Sexpm1, 1, 1, 0,
+  "Return the exp (x)-1 of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = expm1 (d), num);
+  return make_float (d);
+}
+
+DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0,
+  "Return the log gamma of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = lgamma (d), num);
+  return make_float (d);
+}
+
+DEFUN ("log", Flog, Slog, 1, 1, 0,
+  "Return the natural logarithm of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = log (d), num);
+  return make_float (d);
+}
+
+DEFUN ("log10", Flog10, Slog10, 1, 1, 0,
+  "Return the logarithm base 10 of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = log10 (d), num);
+  return make_float (d);
+}
+
+DEFUN ("log1p", Flog1p, Slog1p, 1, 1, 0,
+  "Return the log (1+x) of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = log1p (d), num);
+  return make_float (d);
+}
+
+DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
+  "Return the exponential x ** y.")
+  (num1, num2)
+     register Lisp_Object num1, num2;
+{
+  double f1, f2;
+
+  CHECK_NUMBER_OR_FLOAT (num1, 0);
+  CHECK_NUMBER_OR_FLOAT (num2, 0);
+  if ((XTYPE (num1) == Lisp_Int) && /* common lisp spec */
+      (XTYPE (num2) == Lisp_Int)) /* don't promote, if both are ints */
+    {                           /* this can be improved by pre-calculating */
+      int acc, x, y;            /* some binary powers of x then acumulating */
+      /* these, therby saving some time. -wsr */
+      x = XINT (num1);
+      y = XINT (num2);
+      acc = 1;
+      
+      if (y < 0)
+        {
+          for (; y < 0; y++)
+            acc /= x;
+        }
+      else
+        {
+          for (; y > 0; y--)
+            acc *= x;
+        }
+      return XSET (x, Lisp_Int, acc);
+    }
+  f1 = (XTYPE (num1) == Lisp_Float) ? XFLOAT (num1)->data : XINT (num1);
+  f2 = (XTYPE (num2) == Lisp_Float) ? XFLOAT (num2)->data : XINT (num2);
+  IN_FLOAT (f1 = pow (f1, f2), num1);
+  return make_float (f1);
+}
+
+DEFUN ("sin", Fsin, Ssin, 1, 1, 0,
+  "Return the sine of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = sin (d), num);
+  return make_float (d);
+}
+
+DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0,
+  "Return the hyperbolic sine of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = sinh (d), num);
+  return make_float (d);
+}
+
+DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
+  "Return the square root of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = sqrt (d), num);
+  return make_float (d);
+}
+
+DEFUN ("tan", Ftan, Stan, 1, 1, 0,
+  "Return the tangent of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = tan (d), num);
+  return make_float (d);
+}
+
+DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0,
+  "Return the hyperbolic tangent of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = tanh (d), num);
+  return make_float (d);
+}
+
+DEFUN ("abs", Fabs, Sabs, 1, 1, 0,
+  "Return the absolute value of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  CHECK_NUMBER_OR_FLOAT (num, 0);
+
+  if (XTYPE (num) == Lisp_Float)
+    IN_FLOAT (num = make_float (fabs (XFLOAT (num)->data)), num);
+  else if (XINT (num) < 0)
+    XSETINT (num, - XFASTINT (num));
+
+  return num;
+}
+
+DEFUN ("float", Ffloat, Sfloat, 1, 1, 0,
+  "Return the floating point number equal to ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  CHECK_NUMBER_OR_FLOAT (num, 0);
+
+  if (XTYPE (num) == Lisp_Int)
+    return make_float ((double) XINT (num));
+  else                          /* give 'em the same float back */
+    return num;
+}
+
+DEFUN ("logb", Flogb, Slogb, 1, 1, 0,
+  "Returns the integer that is the base 2 log of ARG.\n\
+This is the same as the exponent of a float.")
+     (num)
+Lisp_Object num;
+{
+  Lisp_Object val;
+  double f;
+
+  CHECK_NUMBER_OR_FLOAT (num, 0);
+  f = (XTYPE (num) == Lisp_Float) ? XFLOAT (num)->data : XINT (num);
+  IN_FLOAT (val = logb (f), num);
+  XSET (val, Lisp_Int, val);
+  return val;
+}
+
+/* the rounding functions  */
+
+DEFUN ("ceiling", Fceiling, Sceiling, 1, 1, 0,
+  "Return the smallest integer no less than ARG.  (Round toward +inf.)")
+  (num)
+     register Lisp_Object num;
+{
+  CHECK_NUMBER_OR_FLOAT (num, 0);
+
+  if (XTYPE (num) == Lisp_Float)
+    IN_FLOAT (XSET (num, Lisp_Int, ceil (XFLOAT (num)->data)), num);
+
+  return num;
+}
+
+DEFUN ("floor", Ffloor, Sfloor, 1, 1, 0,
+  "Return the largest integer no greater than ARG.  (Round towards -inf.)")
+  (num)
+     register Lisp_Object num;
+{
+  CHECK_NUMBER_OR_FLOAT (num, 0);
+
+  if (XTYPE (num) == Lisp_Float)
+    IN_FLOAT (XSET (num, Lisp_Int, floor (XFLOAT (num)->data)), num);
+
+  return num;
+}
+
+DEFUN ("round", Fround, Sround, 1, 1, 0,
+  "Return the nearest integer to ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  CHECK_NUMBER_OR_FLOAT (num, 0);
+
+  if (XTYPE (num) == Lisp_Float)
+    IN_FLOAT (XSET (num, Lisp_Int, rint (XFLOAT (num)->data)), num);
+
+  return num;
+}
+
+DEFUN ("truncate", Ftruncate, Struncate, 1, 1, 0,
+       "Truncate a floating point number to an int.\n\
+Rounds the value toward zero.")
+  (num)
+     register Lisp_Object num;
+{
+  CHECK_NUMBER_OR_FLOAT (num, 0);
+
+  if (XTYPE (num) == Lisp_Float)
+    XSET (num, Lisp_Int, (int) XFLOAT (num)->data);
+
+  return num;
+}
+
+#ifdef BSD
+static
+float_error (signo)
+     int signo;
+{
+  if (! in_float)
+    fatal_error_signal (signo);
+
+#ifdef BSD4_1
+  sigrelse (SIGILL);
+#else /* not BSD4_1 */
+  sigsetmask (0);
+#endif /* not BSD4_1 */
+
+  in_float = 0;
+
+  Fsignal (Qarith_error, Fcons (float_error_arg, Qnil));
+}
+
+/* Another idea was to replace the library function `infnan'
+   where SIGILL is signaled.  */
+
+#endif /* BSD */
+
+init_floatfns ()
+{
+  signal (SIGILL, float_error);
+  in_float = 0;
+}
+
+syms_of_floatfns ()
+{
+  defsubr (&Sacos);
+  defsubr (&Sacosh);
+  defsubr (&Sasin);
+  defsubr (&Sasinh);
+  defsubr (&Satan);
+  defsubr (&Satanh);
+  defsubr (&Sbessel_y0);
+  defsubr (&Sbessel_y1);
+  defsubr (&Sbessel_yn);
+  defsubr (&Sbessel_j0);
+  defsubr (&Sbessel_j1);
+  defsubr (&Sbessel_jn);
+  defsubr (&Scube_root);
+  defsubr (&Scos);
+  defsubr (&Scosh);
+  defsubr (&Serf);
+  defsubr (&Serfc);
+  defsubr (&Sexp);
+  defsubr (&Sexpm1);
+  defsubr (&Slog_gamma);
+  defsubr (&Slog);
+  defsubr (&Slog10);
+  defsubr (&Slog1p);
+  defsubr (&Sexpt);
+  defsubr (&Ssin);
+  defsubr (&Ssinh);
+  defsubr (&Ssqrt);
+  defsubr (&Stan);
+  defsubr (&Stanh);
+
+  defsubr (&Sabs);
+  defsubr (&Sfloat);
+  defsubr (&Slogb);
+  defsubr (&Sceiling);
+  defsubr (&Sfloor);
+  defsubr (&Sround);
+  defsubr (&Struncate);
+}
+
+#else /* not LISP_FLOAT_TYPE */
+
+init_floatfns ()
+{}
+
+syms_of_floatfns ()
+{}
+
+#endif /* not LISP_FLOAT_TYPE */
diff --git a/src/hftctl.c b/src/hftctl.c
new file mode 100644
index 00000000000..3e3788aa709
--- /dev/null
+++ b/src/hftctl.c
@@ -0,0 +1,319 @@
+/* IBM has disclaimed copyright on this module.  */
+
+/***************************************************************/
+/*                                                             */
+/* Function: hftctl                                            */
+/*                                                             */
+/* Syntax:                                                     */
+/*    #include <sys/ioctl.h>                                   */
+/*    #include <sys/hft.h>                                     */
+/*                                                             */
+/*    int hftctl(fildes, request, arg )                        */
+/*    int fildes, request ;                                    */
+/*    char *arg ;                                              */
+/*                                                             */
+/* Description:                                                */
+/*                                                             */
+/*    Does the following:                                      */
+/*      1. determines if fildes is pty                         */
+/*         does normal ioctl it is not                         */
+/*      2. places fildes into raw mode                         */
+/*      3. converts ioctl arguments to datastream              */
+/*      4. waits for 2 secs for acknowledgement before         */
+/*         timimg out.                                         */
+/*      5. places response in callers buffer ( just like       */
+/*         ioctl.                                              */
+/*      6. returns fildes to its original mode                 */
+/*                                                             */
+/*    User of this program should review steps 1,4, and 3.     */
+/*    hftctl makes no check on the request type. It must be    */
+/*    a HFT ioctl that is supported remotely.                  */
+/*    This program will use the SIGALRM and alarm(2).  Any     */
+/*    Previous alarms are lost.                                */
+/*                                                             */
+/*    Users of this program are free to modify it any way      */
+/*    they want.                                               */
+/*                                                             */
+/* Return Value:                                               */
+/*                                                             */
+/*    If ioctl fails, a value of -1 is returned and errno      */
+/*    is set to indicate the error.                            */
+/*                                                             */
+/***************************************************************/
+
+
+#include <stdio.h>
+#include <fcntl.h>
+#include <errno.h>
+#include <setjmp.h>
+#include <sys/ioctl.h>
+#include <sys/signal.h>
+#include <sys/devinfo.h>
+#include <termio.h>
+#include <sys/hft.h>
+#include <termios.h>
+#include <sys/tty.h>
+/* #include <sys/pty.h> */
+#define REMOTE 0x01
+
+#undef ioctl
+static char     SCCSid[] = "com/gnuemacs/src,3.1,9021-90/05/03-5/3/90" ;
+
+/*************** LOCAL DEFINES **********************************/
+
+typedef int     (*FUNC)() ;     /* pointer to a function        */
+
+#define QDEV   ((HFQPDEVCH<<8)|HFQPDEVCL)
+#define QLOC   ((HFQLOCCH<<8)|HFQLOCCL)
+#define QPS    ((HFQPRESCH<<8)|HFQPRESCL)
+
+/*************** EXTERNAL / GLOBAL DATA AREA ********************/
+
+       int              hfqry() ;
+       int              hfskbd() ;
+       char            *malloc() ;
+
+extern int              errno ;
+static jmp_buf          hftenv ;
+static int              is_ack_vtd ;
+static FUNC             sav_alrm ;
+static struct hfctlreq  req =
+                        { 0x1b,'[','x',0,0,0,21,HFCTLREQCH,HFCTLREQCL};
+static struct hfctlack  ACK =
+                        { 0x1b,'[','x',0,0,0,21,HFCTLACKCH,HFCTLACKCL};
+
+       /* FUNC             signal() ; */
+
+/*************** LOCAL MACROS ***********************************/
+
+#define HFTYPE(p)   ((p->hf_typehi<<8)|(p->hf_typelo))
+
+#define BYTE4(p)    ( (p)[0]<<24 | (p)[1]<<16 | (p)[2]<<8 | (p)[3] )
+
+                                        /* read a buffer        */
+#define RD_BUF(f,p,l) \
+        while ( (l) ) \
+          if ( ( j = read((f),(p),(l)) ) < 0 ) \
+             if ( errno != EINTR ) return (-1) ; \
+             else continue ; \
+          else { (l)-=j ; (p)+=j ; }
+
+/*************** HFTCTL FUNCTION *******************************/
+
+hftctl( fd, request, arg )
+        int     fd ;
+        int     request ;
+        union {
+        struct hfintro *intro ;
+        struct hfquery *query ;
+        char           *c ;
+        }       arg ;
+{
+
+        int             i ;
+        int             fd_flag ;       /* fcntl flags          */
+register union {
+ struct hfintro         *cmd ;          /* p.cmd - intro des.   */
+ struct hfqphdevc       *ph ;           /* p.ph  - physical dev.*/
+        char            *c ;            /* p.c   - char ptr     */
+        }               p ;             /* general pointer      */
+        int             pty_new ;       /* pty modes            */
+        int             pty_old ;
+        int             retcode ;
+        struct termios   term_new ;      /* terminal attributes  */
+        struct termios   term_old ;
+        struct devinfo  devInfo ;       /* defined in sys/devinfo.h */
+
+
+if ( ioctl( fd, IOCINFO, &devInfo ) == -1 ) return(-1) ;
+
+if ( devInfo.devtype != DD_PSEU )       /* is it a pty? */
+   return (ioctl(fd, request, arg) ) ;  /* no, do IOCTL */
+
+                                /******* START PTY **************/
+                                /**  Pty found, possible HFT    */
+                                /** set new file des as raw     */
+                                /** as you can.                 */
+                                /********************************/
+
+                                /* Get current state of file    */
+                                /* descriptor & save            */
+if ( ( fd_flag = fcntl( fd, F_GETFL, 0 ) ) == -1 ) return (-1) ;
+if ( ioctl( fd, TCGETS, &term_old ) == -1 ) return (-1) ;
+                                /* set terminal attr to raw     */
+                                /* and to delay on read         */
+pty_new = pty_old | REMOTE ;
+memcpy( &term_new, &term_old, sizeof( term_new ) ) ;
+term_new.c_iflag = 0 ;
+term_new.c_oflag = 0 ;
+term_new.c_lflag = 0 ;
+/* term_new.c_line  = 0 ; */
+for ( i = 1 ; i <= 5 ; i++ )
+term_new.c_cc[i] = 0 ;
+term_new.c_cc[0] = -1 ;
+ioctl( fd, TCSETS, &term_new ) ;
+if ( fcntl( fd, F_SETFL, fd_flag & ~O_NDELAY ) == -1 )
+   return(-1) ;
+                                /* call spacific function       */
+if ( request == HFSKBD )
+   retcode = hfskbd( fd, request, arg.c) ;
+else /* assume HFQUERY */
+   retcode = hfqry( fd, request, arg.c) ;
+
+fcntl( fd, F_SETFL, fd_flag ) ; /* reset terminal to original   */
+ioctl( fd, TCSETS, &term_old ) ;
+
+
+return( retcode ) ;             /* return error                 */
+}
+
+/*************** HFSKBD  FUNCTION ******************************/
+static hfskbd(fd, request, arg )
+        int     fd ;
+        int     request ;
+        struct hfbuf *arg ;
+{
+WR_REQ(fd, request, arg->hf_buflen, arg->hf_bufp,0) ;
+return( GT_ACK(fd, request, arg->hf_bufp) ) ;
+}
+
+/*************** HFQUERY FUNCTION ******************************/
+static hfqry(fd, request, arg )
+        int     fd ;
+        int     request ;
+        struct hfquery *arg ;
+{
+WR_REQ(fd, request, arg->hf_cmdlen, arg->hf_cmd, arg->hf_resplen ) ;
+return( GT_ACK(fd, request, arg->hf_resp ) ) ;
+}
+
+
+/*************** GT_ACK FUNCTION ******************************/
+static GT_ACK(fd, req, buf )
+        int     fd ;
+        int     req ;
+        char   *buf ;
+{
+
+        struct hfctlack ack ;
+        int             i = sizeof( ack ) ;
+        int             j = 0 ;
+        union {
+        char            *c ;
+        struct hfctlack *ack ;
+        }               p ;
+
+        int             hft_alrm() ;
+
+is_ack_vtd = 0 ;                        /* flag no ACT VTD yet         */
+
+if ( setjmp( hftenv ) )                 /* set environment in case     */
+   {                                    /* of time out                 */
+   errno=ENODEV ;                       /* if time out, set errno      */
+   return( -1 ) ;                       /* flag error                  */
+   }
+
+alarm(3) ;                              /* time out in 3 secs          */
+sav_alrm = signal( SIGALRM, hft_alrm ) ;/* prepare to catch time out   */
+
+p.ack = &ack ;
+while ( ! is_ack_vtd )                  /* do until valid ACK VTD      */
+  {
+  RD_BUF(fd, p.c, i ) ;                 /* read until a ACK VTD is fill*/
+
+  if ( ! memcmp( &ack, &ACK, sizeof( HFINTROSZ ) ) /* the ACK intro &  */
+       && ( ack.hf_request == req ) )   /* is it the response we want ?*/
+     {                                  /* yes, ACK VTD found          */
+     is_ack_vtd = 1 ;                   /* quickly, flag it            */
+     break ;                            /* get the %$%#@ out of here   */
+     }
+
+  p.ack = &ack ;                        /* no, then skip 1st           */
+  ++p.c ;                               /* char and start over         */
+  i = sizeof( ack ) - 1 ;               /* one less ESC to cry over    */
+
+  while( ( *p.c != 0x1b ) && i )        /* scan for next ESC           */
+     { ++p.c ; --i ; }                  /* if any                      */
+
+  ( i ? memcpy( &ack, p.c, i ) : 0 ) ;  /* if any left over, then move */
+  p.ack = &ack ;                        /* ESC to front of ack struct  */
+  p.c += i ;                            /* skip over whats been read   */
+  i = sizeof( ack ) - i ;               /* set whats left to be read   */
+  }                                     /***** TRY AGAIN               */
+
+alarm(0) ;                              /* ACK VTD received, reset alrm*/
+signal( SIGALRM, sav_alrm ) ;           /* reset signal                */
+
+if ( i = ack.hf_arg_len )               /* any data following ?        */
+   {                                    /* yes,                        */
+   RD_BUF(fd,buf,i) ;                   /* read until it is received   */
+   }
+
+if ( errno = ack.hf_retcode )           /* set errno based on returned */
+   return (-1) ;                         /* code, if 0, then no error   */
+else
+   return (0) ;                        /* if set, then error returned */
+}
+
+/*************** HFT_ALRM FUNCTION ******************************/
+static hft_alrm(sig)                    /* Function hft_alrm - handle  */
+        int             sig ;           /* alarm signal               */
+{
+signal( SIGALRM, sav_alrm ) ;           /* reset to previous          */
+
+if ( is_ack_vtd )                       /* has ack vtd arrived ?      */
+   return(0) ;                          /* yes, then continue         */
+else                                    /* no, then return with error */
+   longjmp( hftenv, -1 ) ;
+
+}
+
+/*********************************************************************/
+/***                                                               ***/
+/***  NOTE: Both the HFCTLREQ and the arg structure should be      ***/
+/***        sent in one io write operation.  If terminal           ***/
+/***        emulators are in NODELAY mode then multiple writes     ***/
+/***        may cause bogus information to be read by the emulator ***/
+/***        depending on the timing.                               ***/
+/***                                                               ***/
+/*********************************************************************/
+
+static WR_REQ(fd, request, cmdlen, cmd, resplen )
+        int             fd ;
+        int             request ;
+        int             cmdlen ;
+        char           *cmd ;
+        int             resplen ;
+{
+        struct {
+        char            *c ;
+        struct hfctlreq *req ;
+        }              p ;
+        int            size ;
+
+        req.hf_request = request ;
+        req.hf_arg_len = cmdlen ;
+        req.hf_rsp_len = resplen ;
+
+if ( cmdlen )                           /* if arg structure to pass    */
+   {
+   size = sizeof( struct hfctlreq ) + cmdlen ;
+   if ( ( p.c = malloc(size) ) == NULL ) /* malloc one area            */
+      return( -1 ) ;
+
+   memcpy( p.c, &req, sizeof( req ) ) ; /* copy CTL REQ struct         */
+   memcpy( p.c + sizeof( req ), cmd, cmdlen ) ; /* copy arg struct     */
+   }
+else
+   {
+   p.req = &req ;                       /* otherwise use only CTL REQ  */
+   size = sizeof( req ) ;
+   }
+
+                                        /* write request to terminal   */
+if ( write(fd,p.c,size) == -1 ) return (-1) ;
+if ( p.req != &req )                    /* free if allocated           */
+   free( p.c ) ;
+return (0) ;
+
+}