From aa6044f1b95e70873aed1b9594cd4e9a4b9a6dc8 Mon Sep 17 00:00:00 2001
From: retropikzel <retropikzel@iki.fi>
Date: Fri, 2 Jan 2026 14:43:59 +0200
Subject: [PATCH] Implement most of SRFI-106 TCP side

---
 srfi/106.scm       | 56 ++++++++++++++++++++++++++++++++++++++++++++++
 srfi/106.sld       | 16 ++++++-------
 srfi/106/README.md |  6 +++++
 srfi/106/test.scm  | 17 ++++++++++++++
 4 files changed, 87 insertions(+), 8 deletions(-)

diff --git a/srfi/106.scm b/srfi/106.scm
index ac19b20..20de4e4 100644
--- a/srfi/106.scm
+++ b/srfi/106.scm
@@ -26,6 +26,7 @@
 (define-c-procedure c-poll libc 'poll 'int '(pointer int int))
 (define-c-procedure c-strcpy libc 'strcpy 'int '(pointer pointer))
 (define-c-procedure c-close libc 'close 'int '(int))
+(define-c-procedure c-shutdown libc 'shutdown 'int '(int int))
 
 
 (define-record-type <socket>
@@ -320,3 +321,58 @@
       (c-perror (string->c-utf8 "socket-accept (accept) error"))
       (raise-continuable "socket-accept (accept) error"))
     (make-socket accepted-socket)))
+
+(define (call-with-socket socket thunk)
+  (let ((result (apply thunk (list socket))))
+    (socket-close socket)
+    result))
+
+(define (socket-shutdown socket how)
+  (c-shutdown (socket-file-descriptor socket) how))
+
+(define-syntax address-family
+  (syntax-rules ()
+    ((_ name)
+     (cond ((symbol=? 'name 'inet) *af-inet*)
+           ((symbol=? 'name 'inet6) *af-inet6*)
+           ((symbol=? 'name 'unspec) *af-unspec*)
+           ((symbol=? 'name 'unix) *af-unix*)
+           (else (error "address-family: Unrecognized name" name))))))
+
+(define-syntax address-info
+  (syntax-rules ()
+    ((_ names ...)
+     (apply socket-merge-flags
+            (map (lambda (name)
+                   (cond ((symbol=? name 'canoname) *ai-canoname*)
+                         ((symbol=? name 'numerichost) *ai-numerichost*)
+                         ((symbol=? name 'v4mapped) *ai-v4mapped*)
+                         ((symbol=? name 'all) *ai-all*)
+                         ((symbol=? name 'addrconfig) *ai-addrconfig*)
+                         (else (error "address-info: Unrecognized name" name))))
+                 '(names ...))))))
+
+(define-syntax socket-domain
+  (syntax-rules ()
+    ((_ name)
+     (cond ((symbol=? 'name 'stream) *sock-stream*)
+           ((symbol=? 'name 'datagram) *af-unix*)
+           (else (error "socket-domain: Unrecognized name" name))))))
+
+(define-syntax ip-protocol
+  (syntax-rules ()
+    ((_ name)
+     (cond ((symbol=? 'name 'ip) *ipproto-ip*)
+           ((symbol=? 'name 'tcp) *ipproto-tcp*)
+           ((symbol=? 'name 'udp) *ipproto-udp*)
+           (else (error "ip-protocol: Unrecognized name" name))))))
+
+(define-syntax shutdown-method
+  (syntax-rules ()
+    ((_ names ...)
+     (cond ((and (member 'read '(names ...))
+                 (member 'write '(names ...)))
+            *shut-rdwr*)
+           ((symbol=? (member 'read '(names ...)) 'read) *shut-rd*)
+           ((symbol=? (member 'write '(names ...)) 'write) *shut-wr*)
+           (else (error "shutdown-method: Names must be either read, write or both"))))))
diff --git a/srfi/106.sld b/srfi/106.sld
index 0485279..064c9ca 100644
--- a/srfi/106.sld
+++ b/srfi/106.sld
@@ -10,17 +10,17 @@
           socket-accept
           socket-send
           socket-recv
-          ;socket-shutdown
+          socket-shutdown
           socket-close
           ;socket-input-port
           ;socket-output-port
-          ;call-with-socket
-          ;address-family
-          ;address-info
-          ;socket-domain
-          ;ip-protocol
-          ;message-type
-          ;shutdown-method
+          call-with-socket
+          address-family
+          address-info
+          socket-domain
+          ip-protocol
+          message-type
+          shutdown-method
           socket-merge-flags
           socket-purge-flags
           *af-inet*
diff --git a/srfi/106/README.md b/srfi/106/README.md
index 8170955..45ae300 100644
--- a/srfi/106/README.md
+++ b/srfi/106/README.md
@@ -1 +1,7 @@
 SRFI-106: Basic socket interface
+
+
+Not implemented yet:
+
+- socket-input-port
+- socket-output-port
diff --git a/srfi/106/test.scm b/srfi/106/test.scm
index 3d5fecc..095ab30 100644
--- a/srfi/106/test.scm
+++ b/srfi/106/test.scm
@@ -1,4 +1,21 @@
 
+
+(display "HERE address-family: ")
+(write (address-family inet))
+(newline)
+
+(display "HERE address-info: ")
+(write (address-info v4mapped addrconfig))
+(newline)
+
+(display "HERE socket-domain:")
+(write (socket-domain stream))
+(newline)
+
+(display "HERE ip-protocol: ")
+(write (ip-protocol ip))
+(newline)
+
 (define-c-library libc `("stdlib.h") libc-name '((additional-versions ("0" "6"))))
 (define-c-procedure c-system libc 'system 'int '(pointer))