/* --------------------------------------------------------------------------
 * 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