~ chicken-core (master) 7aa948d04e1449100cebf3ca371fa6787e858864
commit 7aa948d04e1449100cebf3ca371fa6787e858864
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Feb 8 15:08:46 2026 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Feb 8 15:09:37 2026 +0100
add binary custom ports
diff --git a/NEWS b/NEWS
index 81824612..3f1296d3 100644
--- a/NEWS
+++ b/NEWS
@@ -32,6 +32,7 @@
- Added `port-encoding' to the (chicken port) module.
- `make-input-port' and `make-output-port' take their optional
port methods as keyword arguments now.
+ - Added `make-binary-input-port' and `make-binary-output-port'.
- Locatives on strings are now indexed by code-point, not byte.
- `symbol-escape' now also controls whether symbols are printed in
escaped ("|...|") mode or not.
diff --git a/chicken.h b/chicken.h
index f6403c40..f5645633 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1388,6 +1388,7 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_u_i_char_downcase(x) C_make_character(C_utf_char_downcase(C_character_code(x)))
#define C_utf_length(bv) C_fix(C_utf_count((C_char *)C_data_pointer(bv), C_header_size(bv) - 1))
#define C_utf_range_length(bv, from, to) C_fix(C_utf_count((C_char *)C_data_pointer(bv) + C_unfix(from), C_unfix(to) - C_unfix(from)))
+#define C_utf_bytes_needed(b) C_fix(C_utf_expect(C_unfix(b)))
#define C_i_list_ref(lst, i) C_i_car(C_i_list_tail(lst, i))
#define C_u_i_list_ref(lst, i) C_u_i_car(C_i_list_tail(lst, i))
diff --git a/library.scm b/library.scm
index ff407b9e..1edee00a 100644
--- a/library.scm
+++ b/library.scm
@@ -69,8 +69,6 @@
#define C_a_get_current_seconds(ptr, c, dummy) C_int64_to_num(ptr, time(NULL))
#define C_peek_c_string_at(ptr, i) ((C_char *)(((C_char **)ptr)[ i ]))
-#define C_utf_bytes_needed(b) C_fix(C_utf_expect(C_unfix(b)))
-
static C_word
fast_read_line_from_file(C_word str, C_word port, C_word size) {
int n = C_unfix(size);
diff --git a/manual/Module (chicken port) b/manual/Module (chicken port)
index 84de15ce..29fad03d 100644
--- a/manual/Module (chicken port)
+++ b/manual/Module (chicken port)
@@ -102,8 +102,10 @@ Call procedure {{THUNK}} with the current output-port temporarily
bound to {{PORT}}.
==== make-input-port
+==== make-binary-input-port
<procedure>(make-input-port READ-CHAR CHAR-READY? CLOSE #!key peek-char read-bytevector read-line)</procedure>
+<procedure>(make-binary-input-port READ-U8 U8-READY? CLOSE #!key peek-u8 read-bytevector)</procedure>
Returns a custom input port. Common operations on this port are
handled by the given parameters, which should be procedures of no
@@ -113,13 +115,15 @@ procedures:
* {{READ-CHAR}} is the most fundamental reader, and must always be
present. It is a thunk which is called when the next character is
to be read and it should return a character or {{#!eof}}.
-* {{CHAR-READY?}} is a thunk which is called when {{char-ready?}}
-is called on this port and should return {{#t}} or {{#f}}.
+* {{READ-U8}} similar to {{READ-CHAR}} but reads and returns a byte.
+* {{CHAR-READY?}}/{{U8-READY?}} are thunks which are called when {{char-ready?}}
+or {{u8-ready?}} are called on this port and should return {{#t}} or {{#f}}.
* {{CLOSE}} is a thunk which is called when the port is closed.
-* {{peek-char}} is a thunk which is called when {{peek-char}} is
-called on this port and should return a character or {{#!eof}}. If it
-is not provided or {{#f}}, {{READ-CHAR}} will be used instead and the
-created port object handles peeking automatically (by calling {{READ}}
+* {{peek-char}}/{{peek-u8}} are thunks which are called when {{peek-char}}
+or {{peek-u8}} are
+called on this port and should return a character/byte or {{#!eof}}. If
+not provided or {{#f}}, {{READ-CHAR}}/{{READ-U8}} will be used instead and the
+created port object handles peeking automatically (by calling the reader procedure
and buffering the character).
* {{read-bytevector}} is called when {{read-bytevector}} or {{read-string!}} is called (or the
higher-level non-mutating {{read-string}} and {{read-bytevector}}). It will be invoked with 4
@@ -144,21 +148,25 @@ number (ie, the line) and slot 5 is the column number (ie, the
character on the line). If the port's positions are not updated,
{{port-position}} won't work.
-Note that reading binary input from a custom input is only possible
+Note that reading binary input from a custom non-binary input port is only possible
when the {{read-bytevector}} operation is given, as byte-input can
currently not ben synthesized from character-input operations.
==== make-output-port
+==== make-binary-output-port
<procedure>(make-output-port WRITE CLOSE #!key force-output)</procedure>
+<procedure>(make-binary-output-port WRITE CLOSE #!key force-output write-bytevector)</procedure>
Returns a custom output port. Common operations on this port are handled
by the given parameters, which should be procedures. {{WRITE}} is
called when output is sent to the port and receives a single argument,
-a string. {{CLOSE}} is called when the port is closed and should
+a string (or bytevector for binary ports). {{CLOSE}} is called when the port is closed and should
be a procedure of no arguments. {{force-output}} (if provided) is called
-for flushing the output port.
+for flushing the output port. The optional {{write-bytevector}} allows
+more optimized writing of partial buffers and takes 3 arguments: a
+bytevector, a starting position and an endong position.
==== with-error-output-to-port
diff --git a/port.scm b/port.scm
index 0a4e44a2..78a7bd9c 100644
--- a/port.scm
+++ b/port.scm
@@ -40,8 +40,8 @@
(call-with-input-string
call-with-output-string
copy-port
- make-input-port
- make-output-port
+ make-input-port make-binary-input-port
+ make-output-port make-binary-output-port
port-encoding
port-fold
port-for-each
@@ -420,6 +420,116 @@ char *ttyname(int fd) {
(##sys#set-port-data! port data)
port) ) )
+(define make-binary-input-port
+ (lambda (read ready? close #!key peek-u8 read-bytevector)
+ (define read-bv
+ (if read-bytevector
+ (lambda (p n dest start)
+ (let* ((off (getlast p dest start))
+ (start (##core#inline "C_fixnum_plus" start off))
+ (n (##core#inline "C_fixnum_difference" n off)))
+ (##core#inline "C_fixnum_plus"
+ off
+ (read-bytevector dest start (##core#inline "C_fixnum_plus" start n)))))
+ (lambda (p n dest start)
+ (let* ((off (getlast p dest start))
+ (start (##core#inline "C_fixnum_plus" start off))
+ (n (##core#inline "C_fixnum_difference" n off)))
+ (##core#inline "C_fixnum_plus"
+ off
+ (let loop ((i 0))
+ (if (##core#inline "C_fixnum_greater_or_equal_p" i n)
+ i
+ (let ((b (read)))
+ (cond ((eof-object? b) i)
+ (else
+ (##core#inline "C_setsubbyte"
+ dest
+ (##core#inline "C_fixnum_plus" i start)
+ b)
+ (loop (##core#inline "C_fixnum_plus" i 1))))))))))))
+ (define (getlast p dest i)
+ (let ((last (##sys#slot p 10)))
+ (cond (last
+ (##core#inline "C_setsubbyte" dest i (char->integer last))
+ (##sys#setislot p 10 #f)
+ 1)
+ (else 0))))
+ (define (tochar x)
+ (if (eof-object? x)
+ x
+ (integer->char x)))
+ (let* ((class
+ (vector
+ (lambda (p) ; read-char
+ (let ((last (##sys#slot p 10)))
+ (cond (last
+ (##sys#setislot p 10 #f)
+ last)
+ (else (tochar (read)) ) ) ))
+ (lambda (p) ; peek-char
+ (let ((last (##sys#slot p 10)))
+ (cond (peek-u8 (tochar (peek-u8)))
+ (last last)
+ (else
+ (let ((last (tochar (read))))
+ (##sys#setislot p 10 last)
+ last) ) ) ) )
+ #f ; write-char
+ #f ; write-bytevector
+ (lambda (p d) ; close
+ (close))
+ #f ; flush-output
+ (lambda (p) ; char-ready?
+ (ready?) )
+ read-bv ; read-bytevector!
+ #f ; read-line
+ #f))
+ (data (vector #f))
+ (port (##sys#make-port 1 class "(custom binary)" 'custom)))
+ (##sys#setslot port 10 #f)
+ (##sys#setslot port 14 'binary)
+ (##sys#setslot port 15 'binary)
+ (##sys#set-port-data! port data)
+ port) ) )
+
+(define make-binary-output-port
+ (lambda (write close #!key force-output write-bytevector)
+ (define write-bv
+ (or write-bytevector
+ (lambda (bv start end)
+ (##sys#check-bytevector bv 'make-binary-output-port)
+ (let loop ((i start)
+ (end (or end (##sys#size bv))))
+ (unless (##core#inline "C_fixnum_greater_or_equal_p" i end)
+ (write (##core#inline "C_subbyte" bv i))
+ (loop (##core#inline "C_fixnum_plus" i 1) end))))))
+ (let* ((class
+ (vector
+ #f ; read-char
+ #f ; peek-char
+ (lambda (p c) ; write-char
+ (let* ((len (##core#inline "C_utf_bytes" c))
+ (buf (##sys#make-bytevector len))
+ (n (##core#inline "C_utf_insert" buf 0 c)))
+ (write-bv buf 0 len)))
+ (lambda (p bv from to) ; write-bytevector
+ (write-bv bv from to))
+ (lambda (p d) ; close
+ (close))
+ (lambda (p) ; flush-output
+ (when force-output (force-output)) )
+ #f ; char-ready?
+ #f ; read-bytevector!
+ #f ; read-line
+ #f)) ; read-buffered
+ (data (vector #f))
+ (port (##sys#make-port 2 class "(custom binary)" 'custom)))
+ (##sys#set-port-data! port data)
+ (##sys#setslot port 15 'binary)
+ (##sys#setslot port 14 'binary)
+ port) ) )
+
(define (make-bidirectional-port i o)
(let* ((class (vector
(lambda (_) ; read-char
diff --git a/tests/port-tests.scm b/tests/port-tests.scm
index ccf74a68..1962c5eb 100644
--- a/tests/port-tests.scm
+++ b/tests/port-tests.scm
@@ -4,7 +4,8 @@
chicken.process chicken.process.signal chicken.tcp chicken.number-vector)
(import (only (scheme base) input-port-open? output-port-open? open-input-string
- write-string open-output-string get-output-string))
+ write-string open-output-string get-output-string
+ flush-output-port peek-u8 u8-ready? read-u8 write-u8))
(include "test.scm")
(test-begin "ports")
@@ -212,7 +213,7 @@ EOF
((exn i/o file) (printf "OK\n") okay))))))))
(cond-expand
- ((not mingw)
+ ((not windows)
(define proc (process-fork (lambda () (tcp-accept (tcp-listen 8080)))))
@@ -427,6 +428,79 @@ EOF
(test-group
"read-line process port position tests"
(test-port-position read-echo-line/pos))
+
+;; binary custom ports
+
+(define count 1)
+(define open #t)
+
+(define (rdb)
+ (let ((c count))
+ (cond ((> c 5) #!eof)
+ (else
+ (set! count (+ count 1))
+ c))))
+
+(define (brdy?) #t)
+(define (cls) (set! open #f))
+
+(define (rbv bv from to)
+ (let loop ((i from))
+ (if (>= i to)
+ (- i from)
+ (let ((b (rdb)))
+ (if (eof-object? b)
+ (- i from)
+ (begin
+ (u8vector-set! bv i b)
+ (loop (+ i 1))))))))
+
+(define (pkb) count)
+
+(define written '())
+
+(define (wrb b)
+ (set! written (append written (list b))))
+
+(define (wrbv bv from to)
+ (do ((i from (+ i 1)))
+ ((>= i to) (- from to))
+ (wrb (u8vector-ref bv i))))
+
+(define p1 (make-binary-input-port rdb brdy? cls))
+
+(assert (u8-ready? p1))
+(assert (= (read-u8 p1) 1))
+(assert (= (peek-u8 p1) 2))
+(assert (= (read-u8 p1) 2))
+(assert (equal? (read-bytevector 4 p1) '#u8(3 4 5)))
+(assert (eof-object? (read-u8 p1)))
+(close-output-port p1)
+
+(set! count 1)
+(define p2 (make-binary-input-port rdb brdy? cls peek-u8: pkb read-bytevector: rbv))
+
+(assert (u8-ready? p2))
+(assert (= (read-u8 p2) 1))
+(assert (= (peek-u8 p2) 2))
+(assert (= (read-u8 p2) 2))
+(assert (equal? (read-bytevector 4 p2) '#u8(3 4 5)))
+(assert (eof-object? (read-u8 p2)))
+(close-output-port p2)
+
+(define p3 (make-binary-output-port wrb cls))
+(write-u8 99 p3)
+(write-bytevector '#u8(10 11 12) p3)
+(close-output-port p3)
+(assert (equal? written '(99 10 11 12)))
+
+(set! written '())
+(define p4 (make-binary-output-port wrb cls force-output: void write-bytevector: wrbv))
+(write-u8 99 p4)
+(write-bytevector '#u8(10 11 12) p4)
+(flush-output-port p4)
+(close-output-port p4)
+(assert (equal? written '(99 10 11 12)))
;; bytevector I/O, moved here from srf-4-tests.scm:
;; Ticket #1124: read-u8vector! w/o length, dest smaller than source.
diff --git a/types.db b/types.db
index e938cc42..bbc5b72e 100644
--- a/types.db
+++ b/types.db
@@ -1954,6 +1954,8 @@
(chicken.port#copy-port (#(procedure #:enforce) chicken.port#copy-port (* * #!optional (procedure (*) *) (procedure (* output-port) *)) undefined))
(chicken.port#make-input-port (#(procedure #:clean #:enforce) chicken.port#make-input-port ((procedure () (or char eof)) (procedure () *) (procedure () . *) #!rest *) input-port))
(chicken.port#make-output-port (#(procedure #:clean #:enforce) chicken.port#make-output-port ((procedure (string) . *) (procedure () . *) #!rest *) output-port))
+(chicken.port#make-binary-input-port (#(procedure #:clean #:enforce) chicken.port#make-binary-input-port ((procedure () (or fixnum eof)) (procedure () *) (procedure () . *) #!rest *) input-port))
+(chicken.port#make-binary-output-port (#(procedure #:clean #:enforce) chicken.port#make-binary-output-port ((procedure (fixnum) . *) (procedure () . *) #!rest *) output-port))
(chicken.port#port-for-each (#(procedure #:enforce) chicken.port#port-for-each ((procedure (*) *) (procedure () . *)) undefined))
(chicken.port#port-map
Trap