/* --------------------------------------------------------------------------
* omonad.c:
*
* Implementation of the O'Haskell O monad.
*
* ------------------------------------------------------------------------*/
/*
type O s a = (Error -> ()) -> (a -> ()) -> ()
return x = \err -> \cont -> cont x
a >>= b = \err -> \cont -> a err (\x -> b x err cont)
raise x = \err -> \cont -> err x
a `catch` b = \err -> \cont -> a (\x -> b x err cont) cont
get = \err -> \cont -> cont current.state
set x = \err -> \cont -> current.state := x;
cont ()
templ2 a c = \err -> \cont -> let n = mkObj()
n.handler := \x -> c x uncaughtO doneO
n.state := a
cont n
act n a = \err -> \cont -> if n /= current && n.code == NIL then
ready := ready ++ [n];
n.code := n.code ++ [a n.handler doneO];
cont ()
req n a = \err -> \cont -> w := n;
while w.waitsFor /= NIL do
w := w.waitsFor;
if w == current then
err Deadlock;
if n.code == NIL then
ready = ready ++ [n];
n.code := n.code ++ [a (release current err)
(reply current cont)]
()
doneO x = if current.code /= NIL then
ready := ready ++ [current];
()
uncaughtO x = if failOnError
abandon "Process" x
else
()
reply m cont x = m.code := cont x : m.code;
m.waitsFor := NIL;
ready := ready ++ [m];
doneO ()
release m err x = m.code := err ReqAbort : m.code;
m.waitsFor := NIL;
ready := ready ++ [m];
current.handler x
*/
extern char *strerror(int);
#include <errno.h>
static List appendOneTo(List xs,Cell y);
static Void local pushStringN Args((String,Int));
static Void local pushString Args((String));
static Void local pushString(s)
String s; {
pushStringN(s,strlen(s));
}
static Void local pushStringN(s,l) /* push pointer to string onto stack */
String s;
Int l; {
push(nameNil);
while (--l >= 0) {
topfun(consChar(s[l]));
}
}
#define msgsOf(o) fst(snd(o))
#define waitsFor(o) fst(snd(snd(o)))
#define stateOf(o) fst(snd(snd(snd(o))))
#define handlerOf(o) snd(snd(snd(snd(o))))
#define mkObj() pair(OBJREF,pair(NIL,pair(NIL,pair(NIL,NIL))))
primFun(primGet) { /* O monad state read */
updapRoot(primArg(1),stateOf(current));
}
primFun(primSet) { /* O monad state write */
stateOf(current) = primArg(3);
updapRoot(primArg(1),nameUnit);
}
primFun(primTempl) { /* O monad object create */
Cell n = mkObj();
push(namePass);
toparg(primArg(3));
toparg(nameUncaughtO);
toparg(nameDoneO);
handlerOf(n) = pop(); /* = pass 3 uncaughtO doneO */
stateOf(n) = primArg(4); /* = 4 */
updapRoot(primArg(1),n);
}
primFun(primAct) { /* O monad asynchronous send */
eval(primArg(4));
if (whnfHead!=current &&
isNull(msgsOf(whnfHead)) && isNull(waitsFor(whnfHead)))
ready = appendOneTo(ready,(whnfHead));
push(primArg(3));
toparg(handlerOf(whnfHead));
toparg(nameDoneO);
top() = cons(top(),NIL);
msgsOf(whnfHead) = appendOnto(msgsOf(whnfHead),pop());
updapRoot(primArg(1),nameUnit);
}
primFun(primReq) { /* O monad synchronous request */
Cell n, n1;
eval(primArg(4));
n = whnfHead;
n1 = waitsFor(n);
while (nonNull(n1)) {
n = n1;
n1 = waitsFor(n1);
}
if (n == current) {
updapRoot(primArg(2),nameDeadlock);
return;
}
waitsFor(current)=whnfHead;
if (isNull(msgsOf(whnfHead)) && isNull(waitsFor(whnfHead)))
ready = appendOneTo(ready,(whnfHead));
push(primArg(3));
toparg(ap(ap(nameRelease,current),primArg(2)));
toparg(ap(ap(nameReply,current),primArg(1)));
top() = cons(top(),NIL);
msgsOf(whnfHead) = appendOnto(msgsOf(whnfHead),pop());
updateRoot(nameUnit);
}
primFun(primDoneO) {
if (nonNull(msgsOf(current)))
ready = appendOneTo(ready,(current));
updateRoot(nameUnit);
}
primFun(primUncaughtO) {
if (failOnError)
abandon("Process",top());
if (nonNull(msgsOf(current)))
ready = appendOneTo(ready,(current));
updateRoot(nameUnit);
}
primFun(primFix) { /* (a -> O s a) -> O s a */
Cell x;
pushString("fixM: black hole");
x = ap(MUTVAR, ap(nameError, top()));
updateRoot(ap(ap(ap(primArg(3), ap(nameDeref, x)), primArg(2)),
ap(ap(ap(nameFix2, x), primArg(2)), primArg(1))));
}
primFun(primDeref) { /* Ref a -> a */
eval(primArg(1));
updateRoot(snd(whnfHead));
}
primFun(primFix2) { /* Ref a -> (Err -> ()) -> (a -> ()) -> a -> () */
eval(primArg(4));
snd(whnfHead) = primArg(1);
updapRoot(primArg(2), primArg(1));
}
primFun(primReply) {
push(msgsOf(primArg(3)));
top() = cons(ap(primArg(2),primArg(1)),top());
msgsOf(primArg(3)) = pop();
waitsFor(primArg(3)) = NIL;
ready = appendOneTo(ready,(primArg(3)));
updapRoot(nameDoneO,nameUnit);
}
primFun(primRelease) {
push(msgsOf(primArg(3)));
top() = cons(ap(primArg(2),nameReqAbort),top());
msgsOf(primArg(3)) = pop();
waitsFor(primArg(3)) = NIL;
ready = appendOneTo(ready,(primArg(3)));
updapRoot(handlerOf(current),primArg(1));
}
primFun(primSetReader) {
#if O_IP
extern void setReader(int, Cell);
setReader(0, primArg(3));
#else
charReader = primArg(3);
#endif
updapRoot(primArg(1),nameUnit);
}
static void raiseErr(StackPtr root, Name n) {
pushString(strerror(errno));
updapRoot(primArg(2),ap(n,top()));
}
primFun(primWriteFileO) {
fwritePrim(root,FALSE);
if (fst(stack(root)) == primArg(2))
raiseErr(root, nameFileError);
}
primFun(primAppendFileO) {
fwritePrim(root,TRUE);
if (fst(stack(root)) == primArg(2))
raiseErr(root, nameFileError);
}
primFun(primReadFileO) {
primReadFile(root);
if (fst(stack(root)) == primArg(2))
raiseErr(root, nameFileError);
}
static Bool terminate = FALSE;
primFun(primTerminate) {
terminate = TRUE;
updapRoot(primArg(1),nameUnit);
}
#define FINDTEXT(v,f,s) \
if (isNull(v) && isNull(v = f(findText(s)))) { \
fprintf(stderr,"%s not found\n",s); \
fflush(stderr); \
abandon("Program execution", top()); \
}
primFun(primStdEnv) {
#if O_IP
#endif
eval(pop());
if (whnfHead==namePutCharSel)
updateRoot(namePutChar);
else if (whnfHead==namePutStrSel)
updateRoot(namePutStr);
else if (whnfHead==nameSetReaderSel)
updateRoot(nameSetReader);
else if (whnfHead==nameWriteFileSel)
updateRoot(nameWriteFileO);
else if (whnfHead==nameAppendFileSel)
updateRoot(nameAppendFileO);
else if (whnfHead==nameReadFileSel)
updateRoot(nameReadFileO);
else if (whnfHead==nameTimeOfDaySel)
updateRoot(nameTimeOfDay);
else if (whnfHead==nameProgArgsSel)
updateRoot(nameProgArgs);
else if (whnfHead==nameGetEnvSel)
updateRoot(nameGetEnv);
else if (whnfHead==nameTerminateSel)
updateRoot(nameTerminate);
else
internal("primStdEnv");
}
primFun(nullAct) {
updapRoot(primArg(1),nameUnit);
}
static
enum { noMatch,
OProg,
#if O_TK
TkProg,
#if O_TIX
TixProg,
#endif
#endif
} etype = noMatch;
#if O_IP
Bool checkSockets();
void initIP();
# if O_TK
static Bool doCheckSockets = FALSE;
# endif
#endif
Bool tryOExecute(type) /* Execute reactive program if it has type */
Type type; { /* StdEnv -> Cmd () or */
Cell temp, cb; /* TkEnv -> Cmd () or TixEnv -> Cmd () */
#if O_TK /* return True if matching type found */
static Name nameTkEnvironment;
Type typeTkEnvironment;
#if O_TIX
static Name nameTixEnvironment;
Type typeTixEnvironment;
#endif
#endif
static Name nameEnv, nameBindCmd;
String cmdAndArgs;
int actNo;
etype = noMatch;
FINDTEXT(nameBindCmd,findName,"bindCmd");
#if O_TK
#if O_TIX
if (!isNull(typeTixEnvironment=findTycon(findText("TixEnv"))) &&
typeMatches(type,fn(typeTixEnvironment,typeProgO))) {
etype = TixProg;
FINDTEXT(nameTixEnvironment,findName,"primTixEnv");
c_primInitTcl ();
nameEnv = nameTixEnvironment;
} else
#endif
if (!isNull(typeTkEnvironment=findTycon(findText("TkEnv"))) &&
typeMatches(type,fn(typeTkEnvironment,typeProgO))) {
etype = TkProg;
FINDTEXT(nameTkEnvironment,findName,"primTkEnv");
c_primInitTcl ();
nameEnv = nameTkEnvironment;
} else
#endif
{
if (typeMatches(type,typeOProg)) {
etype = OProg;
FINDTEXT(nameStdEnvT,findName,"primStdEnvT");
nameEnv = nameStdEnvT;
}
}
if (etype==noMatch)
return FALSE;
#if O_IP
initIP();
#endif
noechoTerminal();
current = rootObj = mkObj();
stateOf(current) = nameUnit;
handlerOf(current) = nameUncaughtO;
ready = singleton(current);
topfun(ap(nameBindCmd,nameEnv));
toparg(nameUncaughtO);
toparg(nameDoneO);
top() = cons(top(),NIL);
msgsOf(current) = pop();
for (terminate=FALSE; !terminate;) {
while (!terminate && nonNull(ready)) {
current = hd(ready);
ready = tl(ready);
push(hd(msgsOf(current)));
msgsOf(current) = tl(msgsOf(current));
temp = evalWithNoError(pop());
}
if(terminate)
break;
current = rootObj;
switch(etype) {
#if O_TK
#if O_TIX
case(TixProg):
#endif
case(TkProg):
terminate = !c_primRunTcl();
if (!terminate){
#if O_IP
if(doCheckSockets)
{
doCheckSockets = FALSE;
checkSockets(); /* XXX open sockets are ignored */
continue;
}
else
#endif
{
cmdAndArgs = c_primGetTcl();
sscanf(cmdAndArgs,"%i",&actNo);
cb = hd(skipOver(nrcallbacks-actNo,callbacks));
push(cb);
toparg(buildString(cmdAndArgs));
}
}
break;
#endif
default:
#if O_IP
terminate = checkSockets();
continue;
#else
terminate=isNull(charReader);
if (!terminate) {
push(charReader);
toparg(mkChar(readTerminalChar()));
}
#endif
break;
}
if (!terminate) {
toparg(nameUncaughtO);
toparg(nameDoneO);
temp = evalWithNoError(pop());
if (nonNull(temp)) {
push(temp);
abandon("Program execution",top());
}
}
}
#if O_IP
initIP();
#endif
#if O_TK
if(etype==TkProg)c_deleteTcl();
#if O_TIX
if(etype==TixProg)c_deleteTcl();
#endif
#endif
return(TRUE);
}
int gArgc;
char **gArgv;
primFun(primProgArgs) {
int i;
push(nameNil);
for(i=gArgc-1;i>=0;i--) {
pushString(gArgv[i]);
topfun(nameCons);
pushed(1) = ap(top(),pushed(1));
drop();
}
}
primFun(primGetEnv) {
char *s = getenv(evalName(primArg(3)));
if(s) {
pushString(s);
topfun(nameJust);
} else {
push(nameNothing);
}
updapRoot(primArg(1),top());
}
#if UNIX
#include <sys/time.h>
primFun(primTimeOfDay) {
struct timeval t;
gettimeofday(&t,NULL);
updapRoot(primArg(1),ap(ap(mkTuple(2),mkInt(t.tv_sec)),mkInt(t.tv_usec)));
}
#else
#include <time.h>
primFun(primTimeOfDay) {
clock_t uptime = clock();
time_t t = time(NULL);
struct tm *tp = localtime(&t);
long usec = (1000000/CLOCKS_PER_SEC) * (uptime % CLOCKS_PER_SEC);
updapRoot(primArg(1),ap(ap(mkTuple(2),mkInt(tp->tm_sec)),mkInt(usec)));
}
#endif
#if O_IP
#if 0
# define DPRINTF(s) printf s
# if 0
# define XDPRINTF(s) printf s
# else
# define XDPRINTF(s)
# endif
#else
# define DPRINTF(s)
# define XDPRINTF(s)
#endif
#if VC32 | CYGWIN
typedef int socklen_t;
#endif
#if CYGWIN
#define SHUT_RDWR 2
#endif
#if VC32
#include <winsock2.h>
#else
#include <netdb.h>
#include <signal.h>
#include <sys/socket.h>
#include <netinet/in.h>
#include <arpa/inet.h>
#include <unistd.h>
#endif
#define FD_READCHAR 1
#define FD_READSOCK 2
#define FD_RECVSOCK 3
#define FD_ACCPSOCK 4
#define FD_MKTAG(t, fd) (((t) << 16) | fd)
#define FD_GETTAG(x) ((x) >> 16)
#define FD_GETFD(x) ((x) & 0xffff)
static int maxfd = -1;
/* static local void setReader Args((Int,Cell)); */
static local void addSocket Args((Int, Int, Cell));
static local void closeSocket Args((Int, Cell));
static local void closeDeleteSocket Args((Int));
#if O_TK
static local void handleSockets Args((ClientData, Int));
static void
handleSockets(ClientData cd, Int mask)
{
DPRINTF(("handleSockets: sock=%d\n",(int)cd));
stopTkMain = TRUE;
doCheckSockets = TRUE;
}
#endif
static void
addSocket(Int tag, Int sock, Cell client)
{
Cell pr;
#if O_TK
Bool isTkEnv;
Tcl_Channel tc = NULL;
#if O_TIX
isTkEnv = etype == TkProg||etype==TixProg;
#else
isTkEnv = etype == TkProg;
#endif
#endif
DPRINTF(("addSocket: tag=%d, sock=%d\n",tag,sock));
#if O_TK
if(isTkEnv) {
tc = Tcl_MakeFileChannel((ClientData)sock, TCL_READABLE);
if(!tc) {
fprintf(stderr, "addSocket: Tcl_MakeFileChannel returns 0\n");
abandon("Program execution", top());
}
DPRINTF(("Channel name: '%s'\n", Tcl_GetChannelName(tc)));
Tcl_CreateChannelHandler(tc, TCL_READABLE|TCL_EXCEPTION,
handleSockets, NULL);
}
#endif
pr = pair(mkInt(FD_MKTAG(tag, sock)), pair(client,mkInt((Int)
#if O_TK
tc
#else
0
#endif
)));
ip_clients = cons(pr, ip_clients);
}
static void
closeSocket(Int sock, Cell p)
{
int i;
#if O_TK
i = intOf(snd(snd(p)));
DPRINTF(("close channelhandler=%d\n",i));
if(i) {
Tcl_DeleteChannelHandler((Tcl_Channel)i, handleSockets, NULL);
Tcl_Close(interp, (Tcl_Channel)i);
} else
close(sock);
#else
close(sock);
#endif
}
static void
closeDeleteSocket(Int sock)
{
Cell l, p, temp, last;
DPRINTF(("closeDeleteSocket sock=%d\n",sock));
last = NIL;
for (l = ip_clients; l != NIL; l = snd(l)) {
p = fst(l);
if (FD_GETFD(intOf(fst(p))) == sock) {
#if VC32
shutdown(sock, SD_BOTH);
#else
shutdown(sock, SHUT_RDWR);
#endif
closeSocket(sock, p);
if (last == NIL) {
ip_clients = snd(l);
} else {
snd(last) = snd(l);
}
push(fst(snd(p)));
toparg(nameClosed);
toparg(nameUncaughtO);
toparg(nameDoneO);
DPRINTF(("evaluating closed\n"));
temp = evalWithNoError(pop());
if (nonNull(temp)) {
push(temp);
abandon("Program execution",top());
}
return;
} else {
last = l;
}
}
DPRINTF(("*** closeDeleteSocket: %d already closed\n", sock));
}
void
initIP()
{
Cell l, p;
Int sock, tagfd;
#if VC32
struct WSAData wsaData;
static winsockets_init = 0;
int nCode;
if(!winsockets_init) {
winsockets_init = 1;
if ((nCode = WSAStartup(MAKEWORD(1, 1), &wsaData)) != 0) {
fprintf(stderr, "Cannot initialize winsockets.\n");
errAbort();
}
}
#endif
DPRINTF(("initIP\n"));
for (l = ip_clients; l != NIL; l = snd(l)) {
p = fst(l);
tagfd = intOf(fst(p));
switch (FD_GETTAG(tagfd)) {
case FD_READSOCK:
case FD_RECVSOCK:
case FD_ACCPSOCK:
sock = FD_GETFD(tagfd);
DPRINTF(("initIP: close sock=%d\n", sock));
closeSocket(sock, p);
break;
}
}
ip_clients = NIL;
}
primFun(primGetHostByName)
{
String host;
struct hostent *h;
int hostid = 0;
host = evalName(primArg(1));
if (!host)
goto done;
DPRINTF(("primGetHostByName: looking up='%s'\n", host));
#if VC32
if(strcmp(host,"localhost")==0)
host = "127.0.0.1";
hostid = inet_addr(host);
if(hostid != INADDR_NONE)
goto done;
hostid = 0;
#endif
h = gethostbyname(host);
if (!h)
goto done;
memcpy(&hostid, h->h_addr, sizeof hostid);
done:
updateRoot(mkInt(hostid));
}
primFun(primGetNameOfHost)
{
char *addr;
struct hostent *h;
char *host;
int hostid, alen;
eval(primArg(1));
hostid = whnfInt;
DPRINTF(("primGetNameOfHost: hostid=%x\n", hostid));
addr = (char *)&hostid;
alen = sizeof addr;
h = gethostbyaddr(addr, alen, AF_INET);
if (h)
host = h->h_name;
else
host = ""; /* inet_ntoa(*(struct in_addr *)addr); */
pushString(host);
updateRoot(top());
}
primFun(primInet_ntoa) {
int hostid;
eval(primArg(1));
hostid = whnfInt;
pushString(inet_ntoa(*(struct in_addr *)&hostid));
updateRoot(top());
}
primFun(primStrerror) {
pushString(strerror(errno));
updapRoot(primArg(1),top());
}
/* primitive primOpen :: Int -> Int -> (Int -> Cmd ()) -> Action */
primFun(primOpen) {
Int port;
Int sock, hostno;
struct sockaddr_in saddr;
DPRINTF(("primOpen: enter\n"));
eval(primArg(5));
hostno = whnfInt;
eval(primArg(4));
port = whnfInt;
DPRINTF(("primOpen: host=%x port=%d\n", hostno, port));
sock = socket(PF_INET, SOCK_STREAM, 0);
if (sock < 0) {
DPRINTF(("primOpen: socket() error=%d\n", errno));
sock = 0;
} else {
saddr.sin_family = AF_INET;
saddr.sin_addr.s_addr = hostno;
saddr.sin_port = htons(port);
/* XXX Should not block like this */
if (connect(sock, (struct sockaddr *)&saddr, sizeof saddr) < 0) {
DPRINTF(("primOpen: connect() error=%d\n", errno));
sock = 0;
}
}
push(ap(primArg(3), mkInt(sock)));
toparg(nameUncaughtO);
toparg(nameDoneO);
DPRINTF(("primOpen, calling with sock=%d\n",sock));
evalWithNoError(pop()); /* XXX */
updapRoot(primArg(1), nameUnit);
}
/* Int -> Int -> PrimUDPHandler -> Request Int */
primFun(primOpenUDP) {
Int port;
Int sock, hostno;
struct sockaddr_in saddr;
DPRINTF(("primOpenUDP: enter\n"));
eval(primArg(5));
hostno = whnfInt;
eval(primArg(4));
port = whnfInt;
DPRINTF(("primOpen: host=%x port=%d\n", hostno, port));
sock = socket(PF_INET, SOCK_DGRAM, 0);
if (sock < 0) {
DPRINTF(("primOpenUDP: socket() error=%d\n", errno));
raiseErr(root,nameNetError);
return;
}
if(port) {
saddr.sin_family = AF_INET;
saddr.sin_addr.s_addr = hostno;
saddr.sin_port = htons(port);
if (connect(sock, (struct sockaddr *)&saddr, sizeof saddr) < 0) {
DPRINTF(("primOpenUDP: connect() error=%d\n", errno));
raiseErr(root,nameNetError);
return;
}
}
addSocket(FD_RECVSOCK, sock, primArg(3));
updapRoot(primArg(1), mkInt(sock));
}
/* primListen :: Int -> (Int -> Int -> Int -> Cmd ()) -> Request Int */
primFun(primListen) {
Int port, sock;
struct sockaddr_in saddr;
DPRINTF(("primListen: enter\n"));
eval(primArg(4));
port = whnfInt;
sock = socket(PF_INET, SOCK_STREAM, 0);
if (sock < 0) {
DPRINTF(("primListen: socket() error=%d\n", errno));
sock = 0;
}
if(sock) {
saddr.sin_family = AF_INET;
saddr.sin_addr.s_addr = INADDR_ANY;
saddr.sin_port = htons(port);
if (bind(sock, (struct sockaddr *)&saddr, sizeof saddr) < 0) {
DPRINTF(("primListen: bind() error: %s\n", strerror(errno)));
sock = 0;
} else {
if (listen(sock, 3) < 0) {
DPRINTF(("primListen: listen() error: %s\n", strerror(errno)));
sock = 0;
} else {
addSocket(FD_ACCPSOCK, sock, primArg(3));
}
}
}
updapRoot(primArg(1),mkInt(sock));
}
/* Int -> PrimTCPClient -> Action */
primFun(primAddSocket) {
Int sock;
eval(primArg(4));
sock = whnfInt;
addSocket(FD_READSOCK, sock, primArg(3));
updapRoot(primArg(1),nameUnit);
}
void
setReader(int fd, Cell c)
{
ip_clients = cons(pair(mkInt(FD_MKTAG(FD_READCHAR, fd)), pair(c,mkInt(0))),
ip_clients);
}
#if SOLARIS
# ifndef _SOCKLEN_T
typedef size_t socklen_t;
# endif
#endif
Bool
checkSockets(void)
{
Cell l, p, temp, client;
socklen_t fromlen;
Int sock, msock, n, addr;
fd_set fdset;
struct timeval zero;
struct sockaddr_in from;
char buffer[1024];
XDPRINTF(("checkSockets\n"));
FD_ZERO(&fdset);
msock = -1;
for (l = ip_clients; l != NIL; l = snd(l)) {
p = fst(l);
sock = FD_GETFD(intOf(fst(p)));
XDPRINTF(("add sock=%d\n", sock));
FD_SET(sock, &fdset);
if (sock > msock)
msock = sock;
}
if (charReader) {
FD_SET(0, &fdset);
if (0 > msock)
msock = 0;
}
if (msock < 0)
return TRUE;
if (msock > maxfd)
maxfd = msock;
zero.tv_sec = 0;
zero.tv_usec = 50000; /* wait a little to avoid busy wait */
n = select(msock+1, &fdset, NULL, NULL, &zero);
if(n==-1)
DPRINTF(("select error: %s\n", strerror(errno)));
XDPRINTF(("select()=%d, errno=%d\n", n, errno));
if (n <= 0)
return FALSE;
DPRINTF(("input on %d sockets\n", n));
for (l = ip_clients; l != NIL; l = snd(l)) {
p = fst(l);
sock = FD_GETFD(intOf(fst(p)));
client = fst(snd(p));
if (FD_ISSET(sock, &fdset)) {
switch (FD_GETTAG(intOf(fst(p)))) {
case FD_READCHAR:
/* XXX should read from specified fd */
DPRINTF(("reading input\n"));
push(client);
toparg(mkChar(readTerminalChar()));
break;
case FD_READSOCK:
n = recv(sock, buffer, sizeof buffer, 0);
if (n >= 0) {
DPRINTF(("READSOCK: sock=%d, data len=%d data[0]=0x%x\n", sock, n, buffer[0]));
if (n == 0) {
DPRINTF(("sock=%d zero read\n", sock));
closeDeleteSocket(sock);
continue;
} else {
pushStringN(buffer, n);
topfun(ap(ap(ap(client,
nameDeliver),
mkInt(0)),
mkInt(0)));
}
} else {
DPRINTF(("READSOCK: sock=%d, error=%s\n",sock,strerror(errno)));
errAbort();
}
break;
case FD_RECVSOCK:
fromlen = sizeof from;
n = recvfrom(sock, buffer, sizeof buffer, 0, (struct sockaddr *)&from, &fromlen);
if (n >= 0) {
addr = from.sin_addr.s_addr;
DPRINTF(("RECVSOCK: sock=%d, host=%x, port=%d, data len=%d data[0]=0x%x\n",
sock, addr, ntohs(from.sin_port), n, buffer[0]));
pushStringN(buffer, n);
topfun(ap(ap(ap(client,
nameDeliver),
mkInt(addr)),
mkInt(ntohs(from.sin_port))));
} else {
DPRINTF(("RECVSOCK: sock=%n, error=%s\n",sock,strerror(errno)));
errAbort();
}
break;
case FD_ACCPSOCK:
fromlen = sizeof from;
n = accept(sock, (struct sockaddr *)&from, &fromlen);
if (n >= 0) {
DPRINTF(("ACCPSOCK: sock=%d, n=%d\n", sock, n));
push(ap(ap(ap(client, mkInt(from.sin_addr.s_addr)),
mkInt(from.sin_port)),
mkInt(n)));
} else
continue;
break;
default:
abandon("Program execution", 0);
break;
}
toparg(nameUncaughtO);
toparg(nameDoneO);
DPRINTF(("evaluating\n"));
temp = evalWithNoError(pop());
if (nonNull(temp)) {
push(temp);
abandon("Program execution",top());
}
}
}
return FALSE;
}
#if 0
static int theSock;
static void
wrerror()
{
/* Note the error */
/*printf("wrerror\n");*/
closeDeleteSocket(theSock);
}
#endif
/* Int -> Packet -> Action */
primFun(primSend) {
Int sock;
char data[1024];
Int r, pos;
#if 0
void (*oldsig)();
#endif
Cell es = primArg(3);
StackPtr saveSp = sp;
eval(primArg(4));
sock = whnfInt;
DPRINTF(("primSend: sock=%d\n", sock));
for (;;) {
eval(es);
pos = 0;
while (whnfHead==nameCons && pos<sizeof data) {
eval(pop());
data[pos++] = charOf(whnfHead);
eval(pop());
}
DPRINTF(("primSend: datalen=%d data[0]=%x\n", pos, data[0]));
#if 0
oldsig = signal(SIGPIPE, wrerror);
theSock = sock;
#endif
r = send(sock, data, pos, 0);
#if 0
signal(SIGPIPE, oldsig);
#endif
if (r < 0) {
sp = saveSp;
raiseErr(root,nameNetError);
closeDeleteSocket(sock);
return;
}
if (whnfHead==nameNil)
break;
}
sp = saveSp;
updapRoot(primArg(1),nameUnit);
}
/* Int -> Action */
primFun(primClose) {
Int sock;
eval(primArg(3));
sock = whnfInt;
DPRINTF(("primClose: sock=%d\n", sock));
closeDeleteSocket(sock);
updapRoot(primArg(1),nameUnit);
}
/* Int -> Int -> Int -> [Byte] -> Action */
primFun(primTransmit) {
Int hostno, port, sock, r, pos;
socklen_t tolen;
char data[8192];
struct sockaddr_in to;
Cell es = primArg(3);
StackPtr saveSp = sp;
DPRINTF(("primTransmit: enter\n"));
eval(primArg(6));
hostno = whnfInt;
eval(primArg(5));
port = whnfInt;
eval(primArg(4));
sock = whnfInt;
to.sin_port = htons(port);
to.sin_family = AF_INET;
to.sin_addr.s_addr = hostno;
tolen = sizeof to;
eval(es);
pos = 0;
while (whnfHead==nameCons && pos<sizeof data) {
eval(pop());
data[pos++] = charOf(whnfHead);
eval(pop());
}
sp = saveSp;
DPRINTF(("primTransmit: send to host=%x port=%d, len=%d\n", hostno, port, pos));
r = sendto(sock, data, pos, 0, (struct sockaddr *)&to, tolen);
if (r < 0) {
raiseErr(root,nameNetError); /* XXX */
return;
}
updapRoot(primArg(1),nameUnit);
}
/* Int -> PrimUDPHandler -> Request Int */
primFun(primListenUDP) {
Int sock, port;
struct sockaddr_in from;
eval(primArg(4));
port = whnfInt;
DPRINTF(("primListenUDP: port=%d\n", port));
sock = socket(PF_INET, SOCK_DGRAM, 0);
if (sock < 0) {
DPRINTF(("primListenUDP: socket() error=%d\n", errno));
raiseErr(root, nameNetError);
return;
}
memset(&from, 0, sizeof from);
from.sin_family = AF_INET;
from.sin_port = htons(port);
if (bind(sock, (struct sockaddr *)&from, sizeof from) < 0) {
DPRINTF(("primListenUDP: bind() error=%d\n", errno));
raiseErr(root, nameNetError);
return;
}
addSocket(FD_RECVSOCK, sock, primArg(3));
DPRINTF(("primListenUDP: add sock=%d\n", sock));
updapRoot(primArg(1), mkInt(sock));
}
#endif
#if 0
/* For debugging:
appendOneTo(xs,y) = appendOnto(xs,singleton(y))
if y not already in xs
/TH
*/
static List appendOneTo(List xs,Cell y)
{
if (isNull(xs))
return singleton(y);
else {
if(hd(xs)==y)
fprintf(stderr,"%d already in list, not appending.\n",y);
else
tl(xs)=appendOneTo(tl(xs),y);
return xs;
}
}
#else
/* For normal use:
appendOneTo(xs,y) = appendOnto(xs,singleton(y))
*/
static List appendOneTo(List xs,Cell y)
{
return appendOnto(xs,singleton(y));
}
#endif
syntax highlighted by Code2HTML, v. 0.9.1