Rewrite custom binary ports in Scheme, in terms of custom ports

* libguile/r6rs-ports.c: Call out to Scheme instead of defining here.
* libguile/r6rs-ports.h: Put custom binary port decls together, to
deprecate later.
* module/ice-9/binary-ports.scm: Re-implement custom binary ports in
terms of custom ports.

module/ice-9/binary-ports.scm

@@ -1,5 +1,5 @@
 ;;; binary-ports.scm --- Binary IO on ports
-;;; Copyright (C) 2009-2011,2013,2016,2019,2021 Free Software Foundation, Inc.
+;;; Copyright (C) 2009-2011,2013,2016,2019,2021,2023 Free Software Foundation, Inc.
 ;;;
 ;;; This library is free software: you can redistribute it and/or modify
 ;;; it under the terms of the GNU Lesser General Public License as
@@ -27,9 +27,11 @@
 
 (define-module (ice-9 binary-ports)
   #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 custom-ports)
   #:export (eof-object
             open-bytevector-input-port
-            make-custom-binary-input-port
+            open-bytevector-output-port
             get-u8
             lookahead-u8
             get-bytevector-n
@@ -41,7 +43,7 @@
             put-u8
             put-bytevector
             unget-bytevector
-            open-bytevector-output-port
+            make-custom-binary-input-port
             make-custom-binary-output-port
             make-custom-binary-input/output-port
             call-with-input-bytevector
@@ -71,3 +73,110 @@ bytevector composed of the bytes written into the port is returned."
       (let ((bv (get-bytevector)))
         (close-port port)
         bv))))
+
+(define (type-error proc expecting val)
+  (scm-error 'wrong-type-arg proc "Wrong type (expecting `~S'): ~S"
+             (list expecting val) (list val)))
+
+(define (custom-binary-port-read read)
+  (unless (procedure? read)
+    (type-error "custom-binary-port-read" "procedure" read))
+  (lambda (port bv start count)
+    (let ((ret (read bv start count)))
+      (unless (and (exact-integer? ret) (<= 0 ret count))
+        (scm-error 'out-of-range "custom-binary-port-read"
+                   "Value out of range: ~S" (list ret) (list ret)))
+      ret)))
+
+(define (custom-binary-port-write write)
+  (unless (procedure? write)
+    (type-error "custom-binary-port-write" "procedure" write))
+  (lambda (port bv start count)
+    (let ((ret (write bv start count)))
+      (unless (and (exact-integer? ret) (<= 0 ret count))
+        (scm-error 'out-of-range "custom-binary-port-write"
+                   "Value out of range: ~S" (list ret) (list ret)))
+      ret)))
+
+(define (custom-binary-port-seek get-position set-position!)
+  (when get-position
+    (unless (procedure? get-position)
+      (type-error "custom-binary-port-seek" "procedure" get-position)))
+  (when set-position!
+    (unless (procedure? set-position!)
+      (type-error "custom-binary-port-seek" "procedure" set-position!)))
+
+  (define (seek port offset whence)
+    (cond
+     ((eqv? whence SEEK_CUR)
+      (unless get-position
+        (type-error "custom-binary-port-seek"
+                    "R6RS custom binary port with `port-position` support"
+                    port))
+      (if (zero? offset)
+          (get-position)
+          (seek port (+ (get-position) offset) SEEK_SET)))
+     ((eqv? whence SEEK_SET)
+      (unless set-position!
+        (type-error "custom-binary-port-seek"
+                    "Seekable R6RS custom binary port"
+                    port))
+      (set-position! offset)
+      ;; Assume setting the position succeeds.
+      offset)
+     ((eqv? whence SEEK_END)
+      (error "R6RS custom binary ports do not support `SEEK_END'"))))
+  seek)
+
+(define (custom-binary-port-close close)
+  (match close
+    (#f (lambda (port) #t))
+    ((? procedure?) (lambda (port) (close)))
+    (_ (type-error "custom-binary-port-close" "procedure" close))))
+
+(define (custom-binary-port-random-access? set-position!)
+  (if set-position!
+      (lambda (port) #t)
+      (lambda (port) #f)))
+
+(define (make-custom-binary-input-port id read get-position set-position! close)
+  (unless (string? id)
+    (type-error "make-custom-binary-input-port" "string" id))
+  (make-custom-port #:id id
+                    #:read (custom-binary-port-read read)
+                    #:seek (custom-binary-port-seek get-position set-position!)
+                    #:close (custom-binary-port-close close)
+                    #:random-access?
+                    (custom-binary-port-random-access? set-position!)
+                    ;; FIXME: Instead default to current encoding, if
+                    ;; someone reads text from this port.
+                    #:encoding 'ISO-8859-1 #:conversion-strategy 'error))
+
+(define (make-custom-binary-output-port id write get-position set-position!
+                                        close)
+  (unless (string? id)
+    (type-error "make-custom-binary-output-port" "string" id))
+  (make-custom-port #:id id
+                    #:write (custom-binary-port-write write)
+                    #:seek (custom-binary-port-seek get-position set-position!)
+                    #:close (custom-binary-port-close close)
+                    #:random-access?
+                    (custom-binary-port-random-access? set-position!)
+                    ;; FIXME: Instead default to current encoding, if
+                    ;; someone reads text from this port.
+                    #:encoding 'ISO-8859-1 #:conversion-strategy 'error))
+
+(define (make-custom-binary-input/output-port id read write get-position
+                                              set-position! close)
+  (unless (string? id)
+    (type-error "make-custom-binary-input/output-port" "string" id))
+  (make-custom-port #:id id
+                    #:read (custom-binary-port-read read)
+                    #:write (custom-binary-port-write write)
+                    #:seek (custom-binary-port-seek get-position set-position!)
+                    #:close (custom-binary-port-close close)
+                    #:random-access?
+                    (custom-binary-port-random-access? set-position!)
+                    ;; FIXME: Instead default to current encoding, if
+                    ;; someone reads text from this port.
+                    #:encoding 'ISO-8859-1 #:conversion-strategy 'error))