mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2026-09-10 07:46:51 -04:00
Initial revision
This commit is contained in:
Mike Rowan
parent
24c5e809a9
commit
b70021f430
558
src/floatfns.c
Normal file
558
src/floatfns.c
Normal file
|
|
@ -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 */
|
||||
319
src/hftctl.c
Normal file
319
src/hftctl.c
Normal file
|
|
@ -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) ;
|
||||
|
||||
}
|
||||
Loading…
Reference in a new issue