diff --git a/contrib/40.srfi/docs/doc.rst b/contrib/40.srfi/docs/doc.rst
index bc95b39f..1dfc7675 100644
--- a/contrib/40.srfi/docs/doc.rst
+++ b/contrib/40.srfi/docs/doc.rst
@@ -36,6 +36,11 @@ SRFI libraries
Sorting and Marging.
+- `(srfi 106)
+ `_
+
+ Basic socket interface
+
- `(srfi 111)
`_
diff --git a/contrib/40.srfi/examples/106/simple-echo-client.scm b/contrib/40.srfi/examples/106/simple-echo-client.scm
new file mode 100644
index 00000000..cfe22edf
--- /dev/null
+++ b/contrib/40.srfi/examples/106/simple-echo-client.scm
@@ -0,0 +1,29 @@
+; A R7RS port of "simple echo client" example in SRFI 106
+;
+; Copyright (C) Takashi Kato (2012). All Rights Reserved.
+;
+; Permission is hereby granted, free of charge, to any person obtaining a copy
+; of this software and associated documentation files (the "Software"), to deal
+; in the Software without restriction, including without limitation the rights
+; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+; copies of the Software, and to permit persons to whom the Software is
+; furnished to do so, subject to the following conditions:
+;
+; The above copyright notice and this permission notice shall be included in
+; all copies or substantial portions of the Software.
+;
+; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+; SOFTWARE.
+
+(import (scheme base)
+ (srfi 106))
+
+(define echo-client-socket (make-client-socket "localhost" "5000"))
+
+(socket-send echo-client-socket (string->utf8 "hello\r\n"))
+(socket-recv echo-client-socket (string-length "hello\r\n"))
diff --git a/contrib/40.srfi/examples/106/simple-echo-server.scm b/contrib/40.srfi/examples/106/simple-echo-server.scm
new file mode 100644
index 00000000..0c37b66c
--- /dev/null
+++ b/contrib/40.srfi/examples/106/simple-echo-server.scm
@@ -0,0 +1,47 @@
+; A R7RS port of "simple echo server" example in SRFI 106
+;
+; Copyright (C) Takashi Kato (2012). All Rights Reserved.
+;
+; Permission is hereby granted, free of charge, to any person obtaining a copy
+; of this software and associated documentation files (the "Software"), to deal
+; in the Software without restriction, including without limitation the rights
+; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+; copies of the Software, and to permit persons to whom the Software is
+; furnished to do so, subject to the following conditions:
+;
+; The above copyright notice and this permission notice shall be included in
+; all copies or substantial portions of the Software.
+;
+; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+; SOFTWARE.
+
+(import (scheme base)
+ (srfi 106))
+
+(define echo-server-socket (make-server-socket "5000"))
+
+(define (server-run)
+ (define (get-line-from-binary-port bin)
+ (utf8->string
+ (call-with-port (open-output-bytevector)
+ (lambda (out)
+ (let loop ((b (read-u8 bin)))
+ (case b
+ ((10) (get-output-bytevector out))
+ ((13) (loop (read-u8 bin)))
+ (else (write-u8 b out) (loop (read-u8 bin)))))))))
+
+ (call-with-socket (socket-accept echo-server-socket)
+ (lambda (sock)
+ (let ((in (socket-input-port sock))
+ (out (socket-output-port sock)))
+ (let loop ((r (get-line-from-binary-port in)))
+ (write-bytevector (string->utf8 (string-append r "\r\n")) out)
+ (loop (get-line-from-binary-port in)))))))
+
+(server-run)
diff --git a/contrib/40.srfi/nitro.mk b/contrib/40.srfi/nitro.mk
index fbb9ae38..c5fcc36d 100644
--- a/contrib/40.srfi/nitro.mk
+++ b/contrib/40.srfi/nitro.mk
@@ -1,3 +1,4 @@
+CONTRIB_INITS += socket
CONTRIB_LIBS += \
contrib/40.srfi/srfi/1.scm\
contrib/40.srfi/srfi/8.scm\
@@ -6,4 +7,12 @@ CONTRIB_LIBS += \
contrib/40.srfi/srfi/43.scm\
contrib/40.srfi/srfi/60.scm\
contrib/40.srfi/srfi/95.scm\
+ contrib/40.srfi/srfi/106.scm\
contrib/40.srfi/srfi/111.scm
+CONTRIB_SRCS += contrib/40.srfi/src/106.c
+CONTRIB_TESTS += test-srfi
+
+test-srfi: bin/picrin
+ for test in `ls contrib/40.srfi/t/*.scm`; do \
+ bin/picrin "$$test"; \
+ done
diff --git a/contrib/40.srfi/src/106.c b/contrib/40.srfi/src/106.c
new file mode 100644
index 00000000..c90f5c9a
--- /dev/null
+++ b/contrib/40.srfi/src/106.c
@@ -0,0 +1,521 @@
+#include "picrin.h"
+
+#include
+#include
+#include
+#include
+#include
+#include
+#include
+#include
+
+#ifndef EWOULDBLOCK
+#define EWOULDBLOCK EAGAIN
+#endif
+
+struct pic_socket_t {
+ int fd;
+};
+
+PIC_INLINE void
+socket_close(struct pic_socket_t *sock)
+{
+ if (sock != NULL && sock->fd != -1) {
+ close(sock->fd);
+ sock->fd = -1;
+ }
+}
+
+PIC_INLINE void
+ensure_socket_is_open(pic_state *pic, struct pic_socket_t *sock)
+{
+ if (sock != NULL && sock->fd == -1) {
+ pic_errorf(pic, "the socket is already closed");
+ }
+}
+
+static void
+socket_dtor(pic_state *pic, void *data)
+{
+ struct pic_socket_t *sock;
+
+ sock = data;
+ socket_close(sock);
+ pic_free(pic, data);
+}
+
+static const pic_data_type socket_type = { "socket", socket_dtor, NULL };
+
+#define pic_socket_p(o) (pic_data_type_p((o), &socket_type))
+#define pic_socket_data_ptr(o) ((struct pic_socket_t *)pic_data_ptr(o)->data)
+
+PIC_INLINE void
+validate_socket_object(pic_state *pic, pic_value v)
+{
+ if (! pic_socket_p(v)) {
+ pic_errorf(pic, "~s is not a socket object", v);
+ }
+}
+
+static pic_value
+pic_socket_socket_p(pic_state *pic)
+{
+ pic_value obj;
+
+ pic_get_args(pic, "o", &obj);
+ return pic_bool_value(pic_socket_p(obj));
+}
+
+static pic_value
+pic_socket_make_socket(pic_state *pic)
+{
+ pic_value n, s;
+ const char *node, *service;
+ int family, socktype, flags, protocol;
+ int result;
+ struct addrinfo hints, *ai, *it;
+ struct pic_socket_t *sock;
+
+ pic_get_args(pic, "ooiiii", &n, &s, &family, &socktype, &flags, &protocol);
+
+ node = service = NULL;
+ if (pic_str_p(n)) {
+ node = pic_str_cstr(pic, pic_str_ptr(n));
+ }
+ if (pic_str_p(s)) {
+ service = pic_str_cstr(pic, pic_str_ptr(s));
+ }
+
+ sock = pic_malloc(pic, sizeof(struct pic_socket_t));
+ sock->fd = -1;
+
+ memset(&hints, 0, sizeof(struct addrinfo));
+ hints.ai_family = family;
+ hints.ai_socktype = socktype;
+ hints.ai_flags = flags;
+ hints.ai_protocol = protocol;
+
+ errno = 0;
+
+ do {
+ result = getaddrinfo(node, service, &hints, &ai);
+ } while (result == EAI_AGAIN);
+ if (result) {
+ if (result == EAI_SYSTEM) {
+ pic_errorf(pic, "%s", strerror(errno));
+ }
+ pic_errorf(pic, "%s", gai_strerror(result));
+ }
+
+ for (it = ai; it != NULL; it = it->ai_next) {
+ int fd;
+
+ fd = socket(it->ai_family, it->ai_socktype, it->ai_protocol);
+ if (fd == -1) {
+ continue;
+ }
+
+ if (it->ai_flags & AI_PASSIVE) {
+ int yes = 1;
+ if (setsockopt(fd, SOL_SOCKET, SO_REUSEADDR, &yes, sizeof(int)) == 0 &&
+ bind(fd, it->ai_addr, it->ai_addrlen) == 0) {
+ if (it->ai_socktype == SOCK_STREAM ||
+ it->ai_socktype == SOCK_SEQPACKET) {
+ /* TODO: Backlog should be configurable. */
+ if (listen(fd, 8) == 0) {
+ sock->fd = fd;
+ break;
+ }
+ } else {
+ sock->fd = fd;
+ break;
+ }
+ }
+ } else {
+ if (connect(fd, it->ai_addr, it->ai_addrlen) == 0) {
+ sock->fd = fd;
+ break;
+ }
+ }
+
+ close(fd);
+ }
+
+ freeaddrinfo(ai);
+
+ if (sock->fd == -1) {
+ pic_errorf(pic, "%s", strerror(errno));
+ }
+
+ return pic_obj_value(pic_data_alloc(pic, &socket_type, sock));
+}
+
+static pic_value
+pic_socket_socket_accept(pic_state *pic)
+{
+ pic_value obj;
+ int fd = -1;
+ struct pic_socket_t *sock, *new_sock;
+
+ pic_get_args(pic, "o", &obj);
+ validate_socket_object(pic, obj);
+
+ sock = pic_socket_data_ptr(obj);
+ ensure_socket_is_open(pic, sock);
+
+ errno = 0;
+ while (1) {
+ struct sockaddr_storage addr;
+ socklen_t addrlen = sizeof(struct sockaddr_storage);
+
+ fd = accept(sock->fd, (struct sockaddr *)&addr, &addrlen);
+
+ if (fd < 0) {
+ if (errno == EINTR) {
+ continue;
+ } else if (errno == EAGAIN || errno == EWOULDBLOCK) {
+ continue;
+ } else {
+ pic_errorf(pic, "%s", strerror(errno));
+ }
+ } else {
+ break;
+ }
+ }
+
+ new_sock = pic_malloc(pic, sizeof(struct pic_socket_t));
+ new_sock->fd = fd;
+ return pic_obj_value(pic_data_alloc(pic, &socket_type, new_sock));
+}
+
+static pic_value
+pic_socket_socket_send(pic_state *pic)
+{
+ pic_value obj;
+ struct pic_blob *bv;
+ const unsigned char *cursor;
+ int flags = 0;
+ size_t remain, written;
+ struct pic_socket_t *sock;
+
+ pic_get_args(pic, "ob|i", &obj, &bv, &flags);
+ validate_socket_object(pic, obj);
+
+ sock = pic_socket_data_ptr(obj);
+ ensure_socket_is_open(pic, sock);
+
+ cursor = bv->data;
+ remain = bv->len;
+ written = 0;
+ errno = 0;
+ while (remain > 0) {
+ ssize_t len = send(sock->fd, cursor, remain, flags);
+ if (len < 0) {
+ if (errno == EINTR) {
+ continue;
+ } else if (errno == EAGAIN || errno == EWOULDBLOCK) {
+ break;
+ } else {
+ pic_errorf(pic, "%s", strerror(errno));
+ }
+ }
+ cursor += len;
+ remain -= len;
+ written += len;
+ }
+
+ return pic_int_value(written);
+}
+
+static pic_value
+pic_socket_socket_recv(pic_state *pic)
+{
+ pic_value obj;
+ struct pic_blob *bv;
+ void *buf;
+ int size;
+ int flags = 0;
+ ssize_t len;
+ struct pic_socket_t *sock;
+
+ pic_get_args(pic, "oi|i", &obj, &size, &flags);
+ validate_socket_object(pic, obj);
+ if (size < 0) {
+ pic_errorf(pic, "size must not be negative");
+ }
+
+ sock = pic_socket_data_ptr(obj);
+ ensure_socket_is_open(pic, sock);
+
+ buf = malloc(size);
+ if (buf == NULL && size > 0) {
+ /* XXX: Is it really OK? */
+ pic_panic(pic, "memory exhausted");
+ }
+
+ errno = 0;
+ do {
+ len = recv(sock->fd, buf, size, flags);
+ } while (len < 0 && (errno == EINTR || errno == EAGAIN || errno == EWOULDBLOCK));
+
+ if (len < 0) {
+ free(buf);
+ pic_errorf(pic, "%s", strerror(errno));
+ }
+
+ bv = pic_make_blob(pic, len);
+ memcpy(bv->data, buf, len);
+ free(buf);
+
+ return pic_obj_value(bv);
+}
+
+static pic_value
+pic_socket_socket_shutdown(pic_state *pic)
+{
+ pic_value obj;
+ int how;
+ struct pic_socket_t *sock;
+
+ pic_get_args(pic, "oi", &obj, &how);
+ validate_socket_object(pic, obj);
+
+ sock = pic_socket_data_ptr(obj);
+ if (sock->fd != -1) {
+ shutdown(sock->fd, how);
+ sock->fd = -1;
+ }
+
+ return pic_undef_value();
+}
+
+static pic_value
+pic_socket_socket_close(pic_state *pic)
+{
+ pic_value obj;
+
+ pic_get_args(pic, "o", &obj);
+ validate_socket_object(pic, obj);
+
+ socket_close(pic_socket_data_ptr(obj));
+
+ return pic_undef_value();
+}
+
+static int
+xf_socket_read(pic_state PIC_UNUSED(*pic), void *cookie, char *ptr, int size)
+{
+ struct pic_socket_t *sock;
+
+ sock = (struct pic_socket_t *)cookie;
+
+ return recv(sock->fd, ptr, size, 0);
+}
+
+static int
+xf_socket_write(pic_state PIC_UNUSED(*pic), void *cookie, const char *ptr, int size)
+{
+ struct pic_socket_t *sock;
+
+ sock = (struct pic_socket_t *)cookie;
+
+ return send(sock->fd, ptr, size, 0);
+}
+
+static long
+xf_socket_seek(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie), long PIC_UNUSED(pos), int PIC_UNUSED(whence))
+{
+ errno = EBADF;
+ return -1;
+}
+
+static int
+xf_socket_close(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie))
+{
+ return 0;
+}
+
+static struct pic_port *
+make_socket_port(pic_state *pic, struct pic_socket_t *sock, short dir)
+{
+ struct pic_port *port;
+
+ port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
+ port->file = xfunopen(pic, sock, xf_socket_read, xf_socket_write, xf_socket_seek, xf_socket_close);
+ port->flags = dir | PIC_PORT_BINARY | PIC_PORT_OPEN;
+ return port;
+}
+
+static pic_value
+pic_socket_socket_input_port(pic_state *pic)
+{
+ pic_value obj;
+ struct pic_socket_t *sock;
+
+ pic_get_args(pic, "o", &obj);
+ validate_socket_object(pic, obj);
+
+ sock = pic_socket_data_ptr(obj);
+ ensure_socket_is_open(pic, sock);
+
+ return pic_obj_value(make_socket_port(pic, sock, PIC_PORT_IN));
+}
+
+static pic_value
+pic_socket_socket_output_port(pic_state *pic)
+{
+ pic_value obj;
+ struct pic_socket_t *sock;
+
+ pic_get_args(pic, "o", &obj);
+ validate_socket_object(pic, obj);
+
+ sock = pic_socket_data_ptr(obj);
+ ensure_socket_is_open(pic, sock);
+
+ return pic_obj_value(make_socket_port(pic, sock, PIC_PORT_OUT));
+}
+
+static pic_value
+pic_socket_call_with_socket(pic_state *pic)
+{
+ pic_value obj, result;
+ struct pic_proc *proc;
+ struct pic_socket_t *sock;
+
+ pic_get_args(pic, "ol", &obj, &proc);
+ validate_socket_object(pic, obj);
+
+ sock = pic_socket_data_ptr(obj);
+ ensure_socket_is_open(pic, sock);
+
+ result = pic_apply1(pic, proc, obj);
+
+ socket_close(sock);
+
+ return result;
+}
+
+void
+pic_init_socket(pic_state *pic)
+{
+ pic_deflibrary (pic, "(srfi 106)") {
+ pic_defun(pic, "socket?", pic_socket_socket_p);
+ pic_defun(pic, "make-socket", pic_socket_make_socket);
+ pic_defun(pic, "socket-accept", pic_socket_socket_accept);
+ pic_defun(pic, "socket-send", pic_socket_socket_send);
+ pic_defun(pic, "socket-recv", pic_socket_socket_recv);
+ pic_defun(pic, "socket-shutdown", pic_socket_socket_shutdown);
+ pic_defun(pic, "socket-close", pic_socket_socket_close);
+ pic_defun(pic, "socket-input-port", pic_socket_socket_input_port);
+ pic_defun(pic, "socket-output-port", pic_socket_socket_output_port);
+ pic_defun(pic, "call-with-socket", pic_socket_call_with_socket);
+
+#ifdef AF_INET
+ pic_define(pic, "*af-inet*", pic_int_value(AF_INET));
+#else
+ pic_define(pic, "*af-inet*", pic_false_value());
+#endif
+#ifdef AF_INET6
+ pic_define(pic, "*af-inet6*", pic_int_value(AF_INET6));
+#else
+ pic_define(pic, "*af-inet6*", pic_false_value());
+#endif
+#ifdef AF_UNSPEC
+ pic_define(pic, "*af-unspec*", pic_int_value(AF_UNSPEC));
+#else
+ pic_define(pic, "*af-unspec*", pic_false_value());
+#endif
+
+#ifdef SOCK_STREAM
+ pic_define(pic, "*sock-stream*", pic_int_value(SOCK_STREAM));
+#else
+ pic_define(pic, "*sock-stream*", pic_false_value());
+#endif
+#ifdef SOCK_DGRAM
+ pic_define(pic, "*sock-dgram*", pic_int_value(SOCK_DGRAM));
+#else
+ pic_define(pic, "*sock-dgram*", pic_false_value());
+#endif
+
+#ifdef AI_CANONNAME
+ pic_define(pic, "*ai-canonname*", pic_int_value(AI_CANONNAME));
+#else
+ pic_define(pic, "*ai-canonname*", pic_false_value());
+#endif
+#ifdef AI_NUMERICHOST
+ pic_define(pic, "*ai-numerichost*", pic_int_value(AI_NUMERICHOST));
+#else
+ pic_define(pic, "*ai-numerichost*", pic_false_value());
+#endif
+/* AI_V4MAPPED and AI_ALL are not supported by *BSDs, even though they are defined in netdb.h. */
+#if defined(AI_V4MAPPED) && !defined(BSD)
+ pic_define(pic, "*ai-v4mapped*", pic_int_value(AI_V4MAPPED));
+#else
+ pic_define(pic, "*ai-v4mapped*", pic_false_value());
+#endif
+#if defined(AI_ALL) && !defined(BSD)
+ pic_define(pic, "*ai-all*", pic_int_value(AI_ALL));
+#else
+ pic_define(pic, "*ai-all*", pic_false_value());
+#endif
+#ifdef AI_ADDRCONFIG
+ pic_define(pic, "*ai-addrconfig*", pic_int_value(AI_ADDRCONFIG));
+#else
+ pic_define(pic, "*ai-addrconfig*", pic_false_value());
+#endif
+#ifdef AI_PASSIVE
+ pic_define(pic, "*ai-passive*", pic_int_value(AI_PASSIVE));
+#else
+ pic_define(pic, "*ai-passive*", pic_false_value());
+#endif
+
+#ifdef IPPROTO_IP
+ pic_define(pic, "*ipproto-ip*", pic_int_value(IPPROTO_IP));
+#else
+ pic_define(pic, "*ipproto-ip*", pic_false_value());
+#endif
+#ifdef IPPROTO_TCP
+ pic_define(pic, "*ipproto-tcp*", pic_int_value(IPPROTO_TCP));
+#else
+ pic_define(pic, "*ipproto-tcp*", pic_false_value());
+#endif
+#ifdef IPPROTO_UDP
+ pic_define(pic, "*ipproto-udp*", pic_int_value(IPPROTO_UDP));
+#else
+ pic_define(pic, "*ipproto-udp*", pic_false_value());
+#endif
+
+#ifdef MSG_PEEK
+ pic_define(pic, "*msg-peek*", pic_int_value(MSG_PEEK));
+#else
+ pic_define(pic, "*msg-peek*", pic_false_value());
+#endif
+#ifdef MSG_OOB
+ pic_define(pic, "*msg-oob*", pic_int_value(MSG_OOB));
+#else
+ pic_define(pic, "*msg-oob*", pic_false_value());
+#endif
+#ifdef MSG_WAITALL
+ pic_define(pic, "*msg-waitall*", pic_int_value(MSG_WAITALL));
+#else
+ pic_define(pic, "*msg-waitall*", pic_false_value());
+#endif
+
+#ifdef SHUT_RD
+ pic_define(pic, "*shut-rd*", pic_int_value(SHUT_RD));
+#else
+ pic_define(pic, "*shut-rd*", pic_false_value());
+#endif
+#ifdef SHUT_WR
+ pic_define(pic, "*shut-wr*", pic_int_value(SHUT_WR));
+#else
+ pic_define(pic, "*shut-wr*", pic_false_value());
+#endif
+#ifdef SHUT_RDWR
+ pic_define(pic, "*shut-rdwr*", pic_int_value(SHUT_RDWR));
+#else
+ pic_define(pic, "*shut-rdwr*", pic_false_value());
+#endif
+ }
+}
diff --git a/contrib/40.srfi/srfi/106.scm b/contrib/40.srfi/srfi/106.scm
new file mode 100644
index 00000000..e224b603
--- /dev/null
+++ b/contrib/40.srfi/srfi/106.scm
@@ -0,0 +1,168 @@
+(define-library (srfi 106)
+ (import (scheme base)
+ (srfi 60)
+ (picrin optional))
+
+ ; TODO: Define assq-ref anywhere else.
+ (define (assq-ref alist key . opt)
+ (cond
+ ((assq key alist) => cdr)
+ (else (if (null? opt) #f (car opt)))))
+
+ (define (socket-merge-flags flag . flags)
+ (if (null? flags)
+ flag
+ (apply socket-merge-flags (logior (or flag 0) (or (car flags) 0))
+ (cdr flags))))
+
+ (define (socket-purge-flags base-flag . flags)
+ (if (null? flags)
+ base-flag
+ (apply socket-purge-flags (logxor (or base-flag 0) (or (car flags) 0))
+ (cdr flags))))
+
+ (define (make-client-socket node service . args)
+ (let-optionals* args ((family *af-inet*)
+ (type *sock-stream*)
+ (flags (socket-merge-flags *ai-v4mapped*
+ *ai-addrconfig*))
+ (protocol *ipproto-ip*))
+ (make-socket node service family type flags protocol)))
+
+ (define (make-server-socket service . args)
+ (let-optionals* args ((family *af-inet*)
+ (type *sock-stream*)
+ (flags *ai-passive*)
+ (protocol *ipproto-ip*))
+ (make-socket #f service family type flags protocol)))
+
+ (define %address-family `((inet . ,*af-inet*)
+ (inet6 . ,*af-inet6*)
+ (unspec . ,*af-unspec*)))
+
+ (define %socket-domain `((stream . ,*sock-stream*)
+ (datagram . ,*sock-dgram*)))
+
+ (define %address-info `((canoname . ,*ai-canonname*)
+ (numerichost . ,*ai-numerichost*)
+ (v4mapped . ,*ai-v4mapped*)
+ (all . ,*ai-all*)
+ (addrconfig . ,*ai-addrconfig*)))
+
+ (define %ip-protocol `((ip . ,*ipproto-ip*)
+ (tcp . ,*ipproto-tcp*)
+ (udp . ,*ipproto-udp*)))
+
+ (define %message-types `((none . 0)
+ (peek . ,*msg-peek*)
+ (oob . ,*msg-oob*)
+ (wait-all . ,*msg-waitall*)))
+
+ (define-syntax address-family
+ (syntax-rules ()
+ ((_ name)
+ (assq-ref %address-family 'name))))
+
+ (define-syntax socket-domain
+ (syntax-rules ()
+ ((_ name)
+ (assq-ref %socket-domain 'name))))
+
+ (define-syntax address-info
+ (syntax-rules ()
+ ((_ names ...)
+ (apply socket-merge-flags
+ (map (lambda (name) (assq-ref %address-info name))
+ '(names ...))))))
+
+ (define-syntax ip-protocol
+ (syntax-rules ()
+ ((_ name)
+ (assq-ref %ip-protocol 'name))))
+
+ (define-syntax message-type
+ (syntax-rules ()
+ ((_ names ...)
+ (apply socket-merge-flags
+ (map (lambda (name) (assq-ref %message-types name))
+ '(names ...))))))
+
+ (define (%shutdown-method names)
+ (define (state->method state)
+ (case state
+ ((read) *shut-rd*)
+ ((write) *shut-wr*)
+ ((read-write) *shut-rdwr*)
+ (else #f)))
+ (let loop ((names names)
+ (state 'none))
+ (cond
+ ((null? names) (state->method state))
+ ((eq? (car names) 'read)
+ (loop (cdr names)
+ (cond
+ ((eq? state 'none) 'read)
+ ((eq? state 'write) 'read-write)
+ (else state))))
+ ((eq? (car names) 'write)
+ (loop (cdr names)
+ (cond
+ ((eq? state 'none) 'write)
+ ((eq? state 'read) 'read-write)
+ (else state))))
+ (else (loop (cdr names) 'other)))))
+
+ (define-syntax shutdown-method
+ (syntax-rules ()
+ ((_ names ...)
+ (%shutdown-method '(names ...)))))
+
+ ;; Constructors and predicate
+ (export make-client-socket
+ make-server-socket
+ socket?)
+
+ ;; Socket operations
+ (export socket-accept
+ socket-send
+ socket-recv
+ socket-shutdown
+ socket-close)
+
+ ;; Port conversion
+ (export socket-input-port
+ socket-output-port)
+
+ ;; Control feature
+ (export call-with-socket)
+
+ ;; Flag operations
+ (export address-family
+ socket-domain
+ address-info
+ ip-protocol
+ message-type
+ shutdown-method
+ socket-merge-flags
+ socket-purge-flags)
+
+ ;; Constant values
+ (export *af-inet*
+ *af-inet6*
+ *af-unspec*)
+ (export *sock-stream*
+ *sock-dgram*)
+ (export *ai-canonname*
+ *ai-numerichost*
+ *ai-v4mapped*
+ *ai-all*
+ *ai-addrconfig*)
+ (export *ipproto-ip*
+ *ipproto-tcp*
+ *ipproto-udp*)
+ (export *msg-peek*
+ *msg-oob*
+ *msg-waitall*)
+ (export *shut-rd*
+ *shut-wr*
+ *shut-rdwr*))
diff --git a/contrib/40.srfi/t/106.scm b/contrib/40.srfi/t/106.scm
new file mode 100644
index 00000000..24c57503
--- /dev/null
+++ b/contrib/40.srfi/t/106.scm
@@ -0,0 +1,72 @@
+(import (scheme base)
+ (srfi 106)
+ (picrin test))
+
+; The number 9600 has no meaning. I just borrowed from Rust.
+(define *test-port* 9600)
+(define (next-test-port)
+ (set! *test-port* (+ *test-port* 1))
+ (number->string *test-port*))
+
+(test #f (socket? '()))
+(let* ((port (next-test-port))
+ (server (make-server-socket port))
+ (client (make-client-socket "127.0.0.1" port)))
+ (test #t (socket? server))
+ (test #t (socket? client)))
+
+(let* ((port (next-test-port))
+ (server (make-server-socket port))
+ (client (make-client-socket "127.0.0.1" port)))
+ (test #t (socket? (socket-accept server))))
+
+(let* ((port (next-test-port))
+ (server (make-server-socket port))
+ (client (make-client-socket "127.0.0.1" port))
+ (conn (socket-accept server)))
+ (test 5 (socket-send conn (string->utf8 "hello")))
+ (test "hello" (utf8->string (socket-recv client 5))))
+
+(let* ((port (next-test-port))
+ (sock (make-server-socket port)))
+ (test #t (port? (socket-input-port sock)))
+ (test #t (port? (socket-output-port sock))))
+
+(test *ai-canonname* (socket-merge-flags *ai-canonname*))
+(test *ai-canonname* (socket-merge-flags *ai-canonname* *ai-canonname*))
+(test *ai-canonname* (socket-purge-flags *ai-canonname*))
+(test *ai-canonname* (socket-purge-flags (socket-merge-flags *ai-canonname* *ai-all*)
+ *ai-all*))
+(test *ai-canonname* (socket-purge-flags (socket-merge-flags *ai-all* *ai-canonname*)
+ *ai-all*))
+
+(test *af-inet* (address-family inet))
+(test *af-inet6* (address-family inet6))
+(test *af-unspec* (address-family unspec))
+
+(test *sock-stream* (socket-domain stream))
+(test *sock-dgram* (socket-domain datagram))
+
+(test *ai-canonname* (address-info canoname))
+(test *ai-numerichost* (address-info numerichost))
+(test *ai-v4mapped* (address-info v4mapped))
+(test *ai-all* (address-info all))
+(test *ai-addrconfig* (address-info addrconfig))
+(test (socket-merge-flags *ai-v4mapped* *ai-addrconfig*)
+ (address-info v4mapped addrconfig))
+
+(test *ipproto-ip* (ip-protocol ip))
+(test *ipproto-tcp* (ip-protocol tcp))
+(test *ipproto-udp* (ip-protocol udp))
+
+(test 0 (message-type none))
+(test *msg-peek* (message-type peek))
+(test *msg-oob* (message-type oob))
+(test *msg-waitall* (message-type wait-all))
+(test (socket-merge-flags *msg-oob* *msg-waitall*)
+ (message-type oob wait-all))
+
+(test *shut-rd* (shutdown-method read))
+(test *shut-wr* (shutdown-method write))
+(test *shut-rdwr* (shutdown-method read write))
+(test *shut-rdwr* (shutdown-method write read))