382 lines
9.9 KiB
C
382 lines
9.9 KiB
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];
|
|
}
|