scsh-0.6/c/extension.c

237 lines
6.7 KiB
C
Raw Normal View History

1999-09-14 08:45:02 -04:00
/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
See file COPYING. */
/* Implementation of the vm-extension opcode. This is completely
optional; nothing in the standard system uses these features.
If you have ANSI C but not POSIX support, try compiling with -DPOSIX=0.
The vm-extension opcode is being phased out. New code should use the
external-call opcode to call C procedures.
floating point: POSIX.1, ANSI C (should we be linking with -lM or -lm?)
sprintf: POSIX.1, ANSI C
atof: POSIX.1, ANSI C
*/
#ifndef POSIX
# define POSIX 2
#endif
#include <stdio.h>
#include "sysdep.h"
#include "scheme48.h"
#include <string.h>
#include <stdlib.h>
#include <math.h>
#include <signal.h>
#include <unistd.h> /* setuid & setgid */
#include <errno.h>
#include <netdb.h> /* gethostbyname */ /* Kali code */
#include <sys/types.h>
#include <sys/wait.h>
#define GREATEST_FIXNUM_VALUE ((1 << 29) - 1)
#define LEAST_FIXNUM_VALUE (-1 << 29)
#define CHANNEL_INDEX(x) EXTRACT_FIXNUM(STOB_REF(x, 1))
#define FOR_INPUT 1
#define FOR_OUTPUT 2
typedef struct {
char b[sizeof(double)];
} unaligned_double;
typedef union {
double f;
unaligned_double b;
} float_or_bytes;
extern long s48_Sextension_valueS; /* how values are returned */
/* return status values */
#define EXT_ST_OKAY 0
#define EXT_ST_EXCEPTION 1
#define EXT_RETURN(value) {s48_Sextension_valueS = (value); return EXT_ST_OKAY; }
#define EXT_EXCEPTION return EXT_ST_EXCEPTION
/******************************************/
s48_value
s48_extended_vm (long key, s48_value value)
{
double x, y;
switch (key) {
/* Cases 0 through 19 are reserved for the mobot system. */
case 0: /* read jumpers on 68000 board */
EXT_RETURN(S48_UNSAFE_ENTER_FIXNUM(0));
/* Floating point */
#define FLOP 100
#define FLOP2(i) case FLOP+(i): \
if (!S48_STOB_P(value) || S48_STOB_DESCRIPTOR_LENGTH(value) != 2) \
EXT_EXCEPTION;
#define FLOP3(i) case FLOP+(i): \
if (!S48_STOB_P(value) || S48_STOB_DESCRIPTOR_LENGTH(value) != 3) \
EXT_EXCEPTION;
#define get_arg(args,i) S48_STOB_REF(args,(i))
#define get_string_arg(args,i) (S48_UNSAFE_EXTRACT_STRING(get_arg(args,i)))
#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) \
{ s48_value temp_ = (stob); \
float_or_bytes loser_; \
if (!S48_STOB_P(temp_)) EXT_EXCEPTION; \
loser_.b = *(unaligned_double*)(&S48_STOB_REF(temp_, 0)); \
(var) = loser_.f; }
#define SET_FLOAT(stob, val) \
{ s48_value temp_ = (stob); \
float_or_bytes loser_; \
if (!S48_STOB_P(temp_)) EXT_EXCEPTION; \
loser_.f = (double)(val); \
*(unaligned_double*)(&S48_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);
EXT_RETURN(S48_UNSPECIFIC);}
FLOP3(1) {
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
set_float_arg(value, 2, x - y);
EXT_RETURN(S48_UNSPECIFIC);}
FLOP3(2) {
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
set_float_arg(value, 2, x * y);
EXT_RETURN(S48_UNSPECIFIC);}
FLOP3(3) {
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
if (y == 0.0) EXT_EXCEPTION;
set_float_arg(value, 2, x / y);
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(4) {
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
EXT_RETURN(S48_ENTER_BOOLEAN(x == y));}
FLOP2(5) {
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
EXT_RETURN(S48_ENTER_BOOLEAN(x < y));}
FLOP2(6) { /* fixnum->float */
s48_value arg = get_arg(value, 0);
if (!S48_FIXNUM_P(arg)) EXT_RETURN(S48_FALSE);
set_float_arg(value, 1, S48_UNSAFE_EXTRACT_FIXNUM(arg));
EXT_RETURN(S48_TRUE);}
FLOP2(7) { /* string->float */
char *str = get_string_arg(value, 0);
set_float_arg(value, 1, atof(str));
EXT_RETURN(S48_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 > S48_UNSAFE_STRING_LENGTH(get_arg(value,1)))
/* unlikely but catastrophic */
fprintf(stderr, "printing float: output too long: %s\n",
str);
EXT_RETURN(S48_UNSAFE_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));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(10) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, log(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(11) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, sin(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(12) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, cos(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(13) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, tan(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(14) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, asin(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(15) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, acos(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP3(16) { /* atan */
get_float_arg(value, 0, y);
get_float_arg(value, 1, x);
set_float_arg(value, 2, atan2(y, x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(17) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, sqrt(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(18) { /* floor */
get_float_arg(value, 0, x);
set_float_arg(value, 1, floor(x));
EXT_RETURN(S48_UNSPECIFIC);}
case FLOP+19: { /* integer? */
EXTRACT_FLOAT(value, x);
EXT_RETURN(S48_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)
{
EXT_RETURN(S48_UNSAFE_ENTER_FIXNUM((long)x)); }
else
EXT_RETURN(S48_FALSE);}
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) EXT_EXCEPTION;
if (y == 0.0) EXT_EXCEPTION;
z = x / y;
set_float_arg(value, 2, z < 0.0 ? ceil(z) : floor(z));
EXT_RETURN(S48_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) EXT_EXCEPTION;
if (y == 0.0) EXT_EXCEPTION;
/* "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));
EXT_RETURN(S48_UNSPECIFIC);}
default:
EXT_EXCEPTION;
}
}