Add partial implementation of inet-pton to (guile).

lib/guile.scm

@@ -774,7 +774,6 @@
     inet-makeaddr
     inet-netof
     inet-ntop
-    inet-pton
     inherit-print-state
     install-r6rs!
     install-r7rs!
@@ -1413,6 +1412,8 @@
           >
           >=
           _
+          AF_INET
+          AF_INET6
           SEEK_CUR
           SEEK_END
           SEEK_SET
@@ -1630,6 +1631,7 @@
           imag-part
           include-from-path
           (rename exact inexact->exact)
+          inet-pton
           inexact?
           inf
           (rename infinite? inf?)
@@ -2629,4 +2631,116 @@ Each call is of the form @code{(proc key value)}."
   (define regexp/icase 'case-insensitive)
   (define regexp/newline 'multiline)
   (define regexp/notbol 'notbol)
-  (define regexp/noteol 'noteol))
+  (define regexp/noteol 'noteol)
+
+  ;; Sockets
+  (define AF_INET 'ipv4)
+  (define AF_INET6 'ipv6)
+  (define (inet-pton family address)
+    (define (bad-address)
+      (error "bad address" family address))
+    (define (check-u8 x)
+      (unless (and x (<= 0 x 255)) (bad-address))
+      x)
+    (define (check-number x)
+      (unless (number? x) (bad-address))
+      x)
+    (define (read-decimal port)
+      (check-u8
+       (string->number
+        (list->string
+         (let lp ()
+           (match (peek-char port)
+             ((and char (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+              (cons (read-char port) (lp)))
+             (_ '())))))))
+    (define (hex-digit? char)
+      (match char
+        ((or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
+             #\a #\b #\c #\d #\e #\f
+             #\A #\B #\C #\D #\E #\F)
+         #t)
+        (_ #f)))
+    (define (read-hexadecimal port)
+      (check-number
+       (string->number
+        (list->string
+         (let lp ((k 0))
+           (match (peek-char port)
+             ((? hex-digit?)
+              (if (= k 4)
+                  (bad-address)
+                  (cons (read-char port) (lp (1+ k)))))
+             (_ '()))))
+        16)))
+    (define (read-dot port)
+      (match (read-char port)
+        (#\. (values))
+        (_ (bad-address))))
+    (define (read-colon port)
+      (match (read-char port)
+        (#\: (values))
+        (_ (bad-address))))
+    (define (read-decimal-and-dot port)
+      (let ((n (read-decimal port)))
+        (read-dot port)
+        n))
+    (define (read-hexadecimal-and-colon port)
+      (let ((n (read-hexadecimal port)))
+        (read-colon port)
+        n))
+    (define (read-ipv6-groups port)
+      (define (iter)
+        (match (peek-char port)
+          ((? eof-object?) '())
+          ((? hex-digit?)
+           (let ((x (read-hexadecimal port)))
+             (match (read-char port)
+               ((? eof-object?) (list x))
+               (#\: (cons x (iter))))))
+          (#\:
+           (read-char port)
+           '())))
+      (match (peek-char port)
+        ((? eof-object?) '())
+        ((? hex-digit?)
+         (iter))
+        (#\:
+         (read-char port)
+         (match (read-char port)
+           (#\: '())
+           (_ (bad-address))))))
+    (match family
+      ('ipv4
+       (call-with-input-string address
+         (lambda (port)
+           (let ((a (read-decimal-and-dot port))
+                 (b (read-decimal-and-dot port))
+                 (c (read-decimal-and-dot port))
+                 (d (read-decimal port)))
+             (if (eof-object? (peek-char port))
+                 (logior (ash a 24)
+                         (ash b 16)
+                         (ash c 8)
+                         d)
+                 (bad-address))))))
+      ;; TODO: IPv6 addresses with embedded IPv4 address.
+      ('ipv6
+       (call-with-input-string address
+         (lambda (port)
+           (let* ((pre (read-ipv6-groups port))
+                  (post (read-ipv6-groups port))
+                  (pad (- 8 (+ (length pre) (length post)))))
+             (if (> pad 0)
+                 (match (append pre (make-list pad 0) post)
+                   ((a b c d e f g h)
+                    (logior (ash a 112)
+                            (ash b 96)
+                            (ash c 80)
+                            (ash d 64)
+                            (ash e 48)
+                            (ash f 32)
+                            (ash g 16)
+                            h))
+                   (_ (bad-address)))
+                 (bad-address)))))))))