Added a simple tcp server facility. See lab/greeting-server.ss.

lab/greeting-server.ss

@@ -0,0 +1,42 @@
+#!/usr/bin/env ikarus --r6rs-script 
+
+(import (ikarus))
+
+(define (get-name p)
+  (list->string 
+    (let f ()
+      (let ([x (read-char p)])
+        (cond
+          [(or (eof-object? x) (char-whitespace? x))
+           '()]
+          [else (cons x (f))])))))
+
+(define serve
+  (case-lambda
+    [(who port)
+     (let ([s (tcp-server-socket 
+                (or (string->number port) 
+                    (error who "invalid port number" port)))])
+       (call/cc
+         (lambda (k) 
+           (with-exception-handler k
+             (lambda () 
+               (let f ()
+                 (let-values ([(op ip) (accept-connection s)])
+                   (let ([op (transcoded-port op (native-transcoder))]
+                         [ip (transcoded-port ip (native-transcoder))])
+                     (display "What's your name? " op) 
+                     (let ([name (get-name ip)])
+                       (printf "Connection from ~s\n" name)
+                       (fprintf op "Got it, ~a\n" name)
+                       (close-input-port ip)
+                       (close-output-port op))))
+                 (f))))))
+       (printf "\nClosing server ...\n")
+       (close-tcp-server-socket s))]
+    [(who)
+     (error who "missing port number")]
+    [(who . args)
+     (error who "too many arguments")]))
+
+(apply serve (command-line))

scheme/ikarus.io.ss

@@ -65,6 +65,7 @@
     
     tcp-connect tcp-connect-nonblocking
     udp-connect udp-connect-nonblocking
+    tcp-server-socket accept-connection close-tcp-server-socket 
     )
 
   
@@ -119,6 +120,7 @@
       process
       tcp-connect tcp-connect-nonblocking
       udp-connect udp-connect-nonblocking
+      tcp-server-socket accept-connection close-tcp-server-socket 
       ))
 
   (module UNSAFE  
@@ -2188,6 +2190,40 @@
     )
 
   
+  (define-struct tcp-server (portnum fd))
+  
+  (define (tcp-server-socket portnum) 
+    (unless (fixnum? portnum)
+      (error 'tcp-server-socket "not a fixnum" portnum))
+    (let ([sock (foreign-call "ikrt_listen" portnum)])
+      (cond
+        [(fx>= sock 0) (make-tcp-server portnum sock)]
+        [else (die 'tcp-server-socket "failed to start server")])))
+
+  (define (accept-connection s)
+    (define who 'accept-connection)
+    (unless (tcp-server? s) 
+      (die who "not a tcp server" s))
+    (let ([fd (tcp-server-fd s)])
+      (unless fd 
+        (die who "server is closed" s))
+      (socket->ports 
+        (foreign-call "ikrt_accept" fd)
+        'accept-connection
+        #f
+        #t)))
+
+  (define (close-tcp-server-socket s)
+    (define who 'close-tcp-server-socket)
+    (unless (tcp-server? s) 
+      (die who "not a tcp server" s))
+    (let ([fd (tcp-server-fd s)])
+      (unless fd 
+        (die who "server is closed" s))
+      ;(file-close-proc who fd)
+      (let ([rv (foreign-call "ikrt_shutdown" fd)])
+        (when (fx< rv 0)
+          (die who "failed to shutdown")))))
 
   (set-fd-nonblocking 0 'init '*stdin*)
   )

scheme/last-revision

@@ -1 +1 @@
-1421
+1422

scheme/makefile.ss

@@ -1397,6 +1397,9 @@
     [udp-connect                      i]
     [tcp-connect-nonblocking          i]
     [udp-connect-nonblocking          i]
+    [tcp-server-socket                i]
+    [close-tcp-server-socket          i]
+    [accept-connection                i]
     [&i/o-would-block                 i]
     [make-i/o-would-block-condition   i]
     [i/o-would-block-condition?       i]

src/ikarus-io.c

@@ -214,6 +214,60 @@ ikrt_select(ikptr fds, ikptr rfds, ikptr wfds, ikptr xfds, ikpcb* pcb){
   return fix(rv);
 }
 
+ikptr
+ikrt_listen(ikptr port, ikpcb* pcb){
+  
+  int sock = socket(AF_INET, SOCK_STREAM, 0);
+  if(sock < 0){
+    return ikrt_io_error();
+  }
+
+  struct sockaddr_in servaddr;
+  memset(&servaddr, 0, sizeof(struct sockaddr_in));
+  servaddr.sin_family = AF_INET;
+  servaddr.sin_addr.s_addr = htonl(INADDR_ANY);
+  servaddr.sin_port = htons(unfix(port));
+
+  int err;
+
+  int reuse = 1;
+  err = setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, &reuse, sizeof(int));
+  if(err < 0){
+    return ikrt_io_error();
+  }
+
+
+  err = bind(sock, (struct sockaddr *)&servaddr, sizeof(servaddr));
+  if(err < 0){
+    return ikrt_io_error();
+  }
+
+  err = listen(sock, 1024);
+  if(err < 0){
+    return ikrt_io_error();
+  }
+  return fix(sock);
+}
+
+ikptr
+ikrt_accept(ikptr s, ikpcb* pcb){
+  int sock = accept(unfix(s), NULL, NULL);
+  if(sock < 0){
+    return ikrt_io_error();
+  } 
+  return fix(sock);
+}
+
+ikptr
+ikrt_shutdown(ikptr s, ikpcb* pcb){
+  int err = shutdown(unfix(s), SHUT_RDWR);
+  if(err < 0){
+    return ikrt_io_error();
+  } 
+  return 0;
+}
+
+
 ikptr
 ikrt_file_ctime(ikptr filename, ikptr res){
   struct stat s;