scsh-0.5/extension.c

/*Copyright (c) 1993 by Richard Kelsey and Jonathan Rees.  See file COPYING.*/


/* Implementation of the vm-extension opcode.  This is completetly
   optional; nothing in the standard system uses these features.
   If you have ANSI C but not POSIX support, try compiling with -DPOSIX=0.

   fdopen: POSIX.1
   getenv: POSIX.1, ANSI C
   setuid, setgid: POSIX.1
   popen: POSIX.2
   floating point: POSIX.1, ANSI C (should we be linking with -lM or -lm?)
   sprintf: POSIX.1, ANSI C
   atof: POSIX.1, ANSI C
   chroot: not standard

 */

#ifndef POSIX
#  define POSIX 2
#endif

#include "sysdep.h"
#include "scheme48.h"

#include <math.h>
#include <signal.h>
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <unistd.h>		/* setuid & setgid */

/* #include <fcntl.h>		/* for O_RDWR */

#define GREATEST_FIXNUM_VALUE ((1 << 29) - 1)
#define LEAST_FIXNUM_VALUE (-1 << 29)
#define PORT_INDEX(x) EXTRACT_FIXNUM(STOB_REF(x, 1))
#define FOR_INPUT 1
#define FOR_OUTPUT 2

FILE **port_to_stream(scheme_value);

typedef struct {
  char b[sizeof(double)];
} unaligned_double;

typedef union {
  double f;
  unaligned_double b;
} float_or_bytes;


/******************************************/

scheme_value
extended_vm (long key, scheme_value value)
{
  double x, y;

  switch (key) {
  
    /* Cases 0 through 19 are reserved for the mobot system. */

  case 0:			/* read jumpers on 68000 board */
    return ENTER_FIXNUM(0);

#if defined(SOCKET_SUPPORT)
  case 20:
    { extern int internet_stream_socket();
      int s = internet_stream_socket();
      return (s < 0) ? UNDEFINED : ENTER_FIXNUM(s);
    }

  case 21:
    { extern int socket_bind(int, int);
      int port = socket_bind(EXTRACT_FIXNUM(value), 0);
      return (port < 0) ? UNDEFINED : ENTER_FIXNUM(port);
    }

  case 22:
    { extern int socket_accept(int);
      int fd = socket_accept(EXTRACT_FIXNUM(value));
      return (fd < 0) ? UNDEFINED : ENTER_FIXNUM(fd);
    }

  case 23:
    if (!PAIRP(value)) return UNDEFINED;
    { extern int socket_connect(char *, int);
      char *hostname = &STRING_REF(CAR(value), 0);
      long port = EXTRACT_FIXNUM(CDR(value));
      int fd;
      fd = socket_connect(hostname, port);
      return (fd < 0) ? UNDEFINED : ENTER_FIXNUM(fd);
    }
#endif

#if POSIX
  /* fdopen() support */
  case 24:
  case 25:
    if (!PAIRP(value)) return UNDEFINED;
    { scheme_value port = CAR(value);
      long fd = EXTRACT_FIXNUM(CDR(value));
      FILE **pstream = port_to_stream(port);
      FILE *new_stream;

      if (pstream == NULL) return UNDEFINED;
      new_stream = fdopen(fd, key == 24 ? "rb" : "wb");
      if (new_stream == NULL) return UNDEFINED;
      fclose(*pstream);
      *pstream = new_stream;
      return UNSPECIFIC;
    }
#endif /* POSIX */

  /* getenv() */
  case 26: {
    scheme_value env_var, result_buffer;
    char *result;
    size_t result_len;
    
    if (!PAIRP(value)) return UNDEFINED;
    env_var = CAR(value);
    result_buffer = CDR(value);
    if (!STRINGP(env_var) || !STRINGP(result_buffer)) return UNDEFINED;
    result = getenv(&STRING_REF(env_var, 0));
    if (result == NULL)
      return SCHFALSE;
    result_len = strlen(result);
    if (result_len > STRING_LENGTH(result_buffer))
      return UNDEFINED;
    strncpy(&STRING_REF(result_buffer, 0), result, result_len);
    return ENTER_FIXNUM(result_len);
  }

#if POSIX
  case 27: {
    /* This is intended for use by HTTP scripts... */
    if (!PAIRP(value) || !FIXNUMP(CAR(value)) || !FIXNUMP(CDR(value)))
      return UNDEFINED;
    if (setgid(EXTRACT_FIXNUM(CDR(value))) != 0) {
      perror("setgid");
      return SCHFALSE; }
    if (setuid(EXTRACT_FIXNUM(CAR(value))) != 0) {
      perror("setuid");
      return SCHFALSE; }
    else
      return SCHTRUE;
  }
#endif

#if defined(HAVE_CHROOT)
  case 28: {
    if (!STRINGP(value))
      return UNDEFINED;
    else if (chroot(&STRING_REF(value, 0)) != 0) {
      perror("chroot");
      return SCHFALSE; }
    else
      return SCHTRUE;
  }
#endif

#if POSIX >= 2
  case 96: {
    int status;
    if (!STRINGP(value))
      return UNDEFINED;
    status = system(&STRING_REF(value, 0));
    if (status == -1) {
      perror("chroot");
      return UNDEFINED; }
    else
      return ENTER_FIXNUM(status); /* cf. waitpid() */
  }

  /* popen() support.  Rather kludgey; there's no pclose(), so
     zombies will pile up. */
  case 97:
  case 98: {
    if (!PAIRP(value)) return UNDEFINED;
    { scheme_value port = CAR(value);
      FILE **pstream = port_to_stream(port);
      scheme_value command = CDR(value);
      FILE *new_stream;
      struct sigaction action;

      if (pstream == NULL) return UNDEFINED;

      action.sa_handler = SIG_IGN;
      action.sa_flags = 0;
      sigemptyset(&action.sa_mask);
      sigaction(SIGPIPE, &action, NULL);

      new_stream = popen(&STRING_REF(command, 0), key == 97 ? "r" : "w");
      if (new_stream == NULL) return UNDEFINED;
      fclose(*pstream);
      *pstream = new_stream;
      return SCHTRUE;
    }
  }
#endif /* POSIX.2 */


  /* Floating point */

#define FLOP 100
#define FLOP2(i) case FLOP+(i): \
		   if (!STOBP(value) || STOB_LLENGTH(value) != 2) \
		     return UNDEFINED;
#define FLOP3(i) case FLOP+(i): \
		   if (!STOBP(value) || STOB_LLENGTH(value) != 3) \
		     return UNDEFINED;

#define get_arg(args,i) STOB_REF(args,(i))
#define get_string_arg(args,i) (&STRING_REF(get_arg(args,i), 0))

#define get_float_arg(args, i, var) EXTRACT_FLOAT(get_arg(args, i), var)
#define set_float_arg(args, i, val) SET_FLOAT(get_arg(args, i), val)

#define EXTRACT_FLOAT(stob, var) \
  { scheme_value temp_ = (stob); \
    float_or_bytes loser_; \
    if (!STOBP(temp_)) return UNDEFINED; \
    loser_.b = *(unaligned_double*)(&STOB_REF(temp_, 0)); \
    (var) = loser_.f; }

#define SET_FLOAT(stob, val) \
  { scheme_value temp_ = (stob); \
    float_or_bytes loser_; \
    if (!STOBP(temp_)) return UNDEFINED; \
    loser_.f = (double)(val); \
    *(unaligned_double*)(&STOB_REF(temp_, 0)) = loser_.b; }

  FLOP3(0) {
    get_float_arg(value, 0, x);
    get_float_arg(value, 1, y);
    set_float_arg(value, 2, x + y);
    return UNSPECIFIC;}
  FLOP3(1) {
    get_float_arg(value, 0, x);
    get_float_arg(value, 1, y);
    set_float_arg(value, 2, x - y);
    return UNSPECIFIC;}
  FLOP3(2) {
    get_float_arg(value, 0, x);
    get_float_arg(value, 1, y);
    set_float_arg(value, 2, x * y);
    return UNSPECIFIC;}
  FLOP3(3) {
    get_float_arg(value, 0, x);
    get_float_arg(value, 1, y);
    if (y == 0.0) return UNDEFINED;
    set_float_arg(value, 2, x / y);
    return UNSPECIFIC;}
  FLOP2(4) {
    get_float_arg(value, 0, x);
    get_float_arg(value, 1, y);
    return ENTER_BOOLEAN(x == y);}
  FLOP2(5) {
    get_float_arg(value, 0, x);
    get_float_arg(value, 1, y);
    return ENTER_BOOLEAN(x < y);}
  FLOP2(6) {			/* fixnum->float */
    scheme_value arg = get_arg(value, 0);
    if (!FIXNUMP(arg)) return SCHFALSE;
    set_float_arg(value, 1, EXTRACT_FIXNUM(arg));
    return SCHTRUE;}
  FLOP2(7) {			/* string->float */
    char *str = get_string_arg(value, 0);
    set_float_arg(value, 1, atof(str));
    return UNSPECIFIC;}
  FLOP2(8) {			/* float->string */
    size_t len;
    char *str = get_string_arg(value,1);
    get_float_arg(value, 0, x);
    sprintf(str, "%g", x);
    len = strlen(str);
    if (len > STRING_LENGTH(get_arg(value,1)))
      /* unlikely but catastrophic */
      fprintf(stderr, "printing float: output too long: %s\n",
	      str);
    return ENTER_FIXNUM(len);}

    /* exp log sin cos tan asin acos atan sqrt */

  FLOP2(9) {
    get_float_arg(value, 0, x);
    set_float_arg(value, 1, exp(x));
    return UNSPECIFIC;}
  FLOP2(10) {
    get_float_arg(value, 0, x);
    set_float_arg(value, 1, log(x));
    return UNSPECIFIC;}
  FLOP2(11) {
    get_float_arg(value, 0, x);
    set_float_arg(value, 1, sin(x));
    return UNSPECIFIC;}
  FLOP2(12) {
    get_float_arg(value, 0, x);
    set_float_arg(value, 1, cos(x));
    return UNSPECIFIC;}
  FLOP2(13) {
    get_float_arg(value, 0, x);
    set_float_arg(value, 1, tan(x));
    return UNSPECIFIC;}
  FLOP2(14) {
    get_float_arg(value, 0, x);
    set_float_arg(value, 1, asin(x));
    return UNSPECIFIC;}
  FLOP2(15) {
    get_float_arg(value, 0, x);
    set_float_arg(value, 1, acos(x));
    return UNSPECIFIC;}
  FLOP3(16) {			/* atan */
    get_float_arg(value, 0, y);
    get_float_arg(value, 1, x);
    set_float_arg(value, 2, atan2(y, x));
    return UNSPECIFIC;}
  FLOP2(17) {
    get_float_arg(value, 0, x);
    set_float_arg(value, 1, sqrt(x));
    return UNSPECIFIC;}

  FLOP2(18) {			/* floor */
    get_float_arg(value, 0, x);
    set_float_arg(value, 1, floor(x));
    return UNSPECIFIC;}
  case FLOP+19: {		/* integer? */
    EXTRACT_FLOAT(value, x);
    return ENTER_BOOLEAN(fmod(x, 1.0) == 0.0); }
  case FLOP+20: {		/* float->fixnum */
    EXTRACT_FLOAT(value, x);
    if (x <= (double)GREATEST_FIXNUM_VALUE
	&& x >= (double)LEAST_FIXNUM_VALUE)
      return ENTER_FIXNUM((long)x);
    else
      return SCHFALSE;}
  FLOP3(21) {			/* quotient */
    double z;
    get_float_arg(value, 0, x);
    get_float_arg(value, 1, y);
    if (fmod(x, 1.0) != 0.0 || fmod(y, 1.0) != 0.0) return UNDEFINED;
    if (y == 0.0) return UNDEFINED;
    z = x / y;
    set_float_arg(value, 2, z < 0.0 ? ceil(z) : floor(z));
    return UNSPECIFIC;}
  FLOP3(22) {			/* remainder */
    get_float_arg(value, 0, x);
    get_float_arg(value, 1, y);
    if (fmod(x, 1.0) != 0.0 || fmod(y, 1.0) != 0.0) return UNDEFINED;
    if (y == 0.0) return UNDEFINED;

    /* "fmod(double x, double y) returns the floating-point remainder
       (f) of the division of x by y, where f has the same sign as x,
       such that x=iy+f for some integer i, and |f| < |y|." */

    set_float_arg(value, 2, fmod(x, y));
    return UNSPECIFIC;}

  default:
    return UNDEFINED;
  }
}


FILE **
port_to_stream(scheme_value port)
{
  int index;
  extern FILE **Sopen_portsS;

  if (!PORTP(port))
    return NULL;		/* not a port */

  index = PORT_INDEX(port);
  if (index < 0)
    return NULL;		/* port not open */

  return &Sopen_portsS[index];
}