From fc904cab73be3180d1100c30106bcb262ae76668 Mon Sep 17 00:00:00 2001 From: vyzo Date: Tue, 26 Sep 2023 11:48:23 +0300 Subject: [PATCH] stdio: implement cooked port adapters (#929) Completes the port adapter zoo Closes https://github.com/mighty-gerbils/gerbil/issues/867 --- src/std/error.ss | 7 + src/std/io/bio/api.ss | 4 +- src/std/io/port-test.ss | 356 ++++++++++++++++++++++++++++++ src/std/io/port.ss | 401 +++++++++++++++++++++++++++++++--- src/std/io/strio/api.ss | 8 +- src/std/text/basic-parsers.ss | 2 +- 6 files changed, 735 insertions(+), 43 deletions(-) create mode 100644 src/std/io/port-test.ss diff --git a/src/std/error.ss b/src/std/error.ss index a0c481c51..1251d609d 100644 --- a/src/std/error.ss +++ b/src/std/error.ss @@ -22,6 +22,7 @@ Timeout Timeout? raise-timeout timeout-error? UnboundKey UnboundKey? raise-unbound-key unbound-key-error? ContextError ContextError? raise-context-error context-error? + UnsupportedMethod? raise-unsupported-method unsupported-method-error? (rename: raise-bug BUG) is-it-bug? with-exception-stack-trace @@ -75,6 +76,9 @@ ;; key lookup errors (deferror-class UnboundKey () unbound-key-error?) +;; unsupported interface methods +(deferror-class UnsupportedMethod () unsupported-method-error?) + ;; utility macros (defsyntax (exception-context stx) (syntax-case stx () @@ -138,6 +142,9 @@ (defraise/context (raise-unbound-key where irritants ...) (UnboundKey "no value associated with key" irritants: [irritants ...])) +(defraise/context (raise-unsupported-method where) + (UnsupportedMethod "unsupported method" irritants: [])) + ;; it's a bug (deferror-class BUG () is-it-bug?) diff --git a/src/std/io/bio/api.ss b/src/std/io/bio/api.ss index 2d414f44c..02edb61e3 100644 --- a/src/std/io/bio/api.ss +++ b/src/std/io/bio/api.ss @@ -44,7 +44,7 @@ (reader (Reader pre-reader))) (BufferedReader (make-input-buffer reader buffer 0 0 #f)))) ((input-port? pre-reader) - (BufferedReader (raw-port pre-reader))) ;; TODO: use a cooked-port instead + (BufferedReader (make-cooked-binary-input-port pre-reader))) (else (raise-bad-argument open-buffered-reader "Reader instance or u8vector" pre-reader)))) @@ -61,7 +61,7 @@ (buffer (make-u8vector-buffer buffer-or-size))) (BufferedWriter (make-output-buffer writer buffer 0 #f)))) ((output-port? pre-writer) - (BufferedWriter (raw-port pre-writer))) ;; TODO: use a cooked-port instead + (BufferedWriter (make-raw-binary-output-port pre-writer))) (else (raise-bad-argument open-buffered-writer "Writer instance or #f" pre-writer)))) diff --git a/src/std/io/port-test.ss b/src/std/io/port-test.ss new file mode 100644 index 000000000..58c72ebd8 --- /dev/null +++ b/src/std/io/port-test.ss @@ -0,0 +1,356 @@ +;;; -*- Gerbil -*- +;;; © vyzo +;;; IO port adapter tests +(import :std/test + :std/error + :std/iter + :std/text/utf8 + ./interface + ./api) +(export binary-input-port-test + binary-output-port-test + textual-input-port-test + textual-output-port-test) + +(def (make-test-u8vector size) + (let (u8v (make-u8vector size)) + (for (i (in-range size)) + (u8vector-set! u8v i (modulo i 256))) + u8v)) + +(def (make-test-string size) + (let (str (make-string size)) + (for (i (in-range size)) + (string-set! str i (integer->char (modulo i 256)))) + str)) + +(def binary-input-port-test + (test-suite "binary input port" + (test-case "u8vector input" + (let* ((u8v (make-test-u8vector 1024)) + (brd (open-buffered-reader (open-input-u8vector u8v))) + (buf (make-u8vector 64))) + (for (i (in-range 16)) + (check (BufferedReader-read brd buf) => 64) + (for (j (in-range 64)) + (check (u8vector-ref buf j) => (modulo (+ (* i 64) j) 256)))) + (check (BufferedReader-read brd buf) => 0) + (check-exception (BufferedReader-read brd buf 0 64 1) io-error?) + (check-exception (BufferedReader-read brd buf 0 64 30) io-error?) + (check-exception (BufferedReader-read brd buf 0 64 64) io-error?))) + + (test-case "u8 input" + (let* ((u8v (make-test-u8vector 1024)) + (brd (open-buffered-reader (open-input-u8vector u8v)))) + (for (i (in-range 1024)) + (check (BufferedReader-peek-u8 brd) => (modulo i 256)) + (check (BufferedReader-read-u8 brd) => (modulo i 256))) + (check (BufferedReader-peek-u8 brd) ? eof-object?) + (check (BufferedReader-read-u8 brd) ? eof-object?))) + + (test-case "input skipping" + (let* ((u8v (make-test-u8vector 1024)) + (brd (open-buffered-reader (open-input-u8vector u8v))) + (buf (make-u8vector 64))) + (BufferedReader-skip brd 3) + (check (BufferedReader-read brd buf) => 64) + (for (i (in-range 64)) + (check (u8vector-ref buf i) => (modulo (+ i 3) 256))) + (BufferedReader-skip brd 950) + (u8vector-fill! buf 0) + (check (BufferedReader-read brd buf) => 7) + (for (i (in-range 7)) + (check (u8vector-ref buf i) => (modulo (+ 1017 i) 256))) + (for (i (in-range 7 64)) + (check (u8vector-ref buf i) => 0)))) + + (test-case "input delimiting" + (let* ((u8v (make-test-u8vector 1024)) + (brd (open-buffered-reader (open-input-u8vector u8v))) + (buf (make-u8vector 64))) + (BufferedReader-skip brd 7) + (let (dbrd (BufferedReader-delimit brd 10)) + (check (BufferedReader-read dbrd buf) => 10) + (for (i (in-range 10)) + (check (u8vector-ref buf i) => (+ 7 i))) + (for (i (in-range 10 64)) + (check (u8vector-ref buf i) => 0)) + (check (BufferedReader-read dbrd buf) => 0)) + (check (BufferedReader-read brd buf) => 64) + (for (i (in-range 64)) + (check (u8vector-ref buf i) => (modulo (+ 17 i) 256))))) + + (test-case "integer input" + (let* ((u8v (u8vector + ;; u16 + #x01 #x02 + ;; u32 + #x01 #x02 #x03 #x04 + ;; u64 + #x01 #x02 #x03 #x04 #x05 #x06 #x07 #x08 + ;; s16 + #x01 #x02 + #x81 #x02 + ;; s32 + #x01 #x02 #x03 #x04 + #x81 #x02 #x03 #x04 + ;; s64 + #x01 #x02 #x03 #x04 #x05 #x06 #x07 #x08 + #x81 #x02 #x03 #x04 #x05 #x06 #x07 #x08 + ;; varuint + #xaf #x96 #x13 + ;; varint + #xde #xac #x26 + #xdd #xac #x26 + )) + (brd (open-buffered-reader (open-input-u8vector u8v)))) + (check (BufferedReader-read-u16 brd) => #x0102) + (check (BufferedReader-read-u32 brd) => #x01020304) + (check (BufferedReader-read-u64 brd) => #x0102030405060708) + (check (BufferedReader-read-s16 brd) => #x0102) + (check (BufferedReader-read-s16 brd) => -32510) + (check (BufferedReader-read-s32 brd) => #x01020304) + (check (BufferedReader-read-s32 brd) => -2130574588) + (check (BufferedReader-read-s64 brd) => #x0102030405060708) + (check (BufferedReader-read-s64 brd) => -9150748177064392952) + (check (BufferedReader-read-varuint brd) => 314159) + (check (BufferedReader-read-varint brd) => 314159) + (check (BufferedReader-read-varint brd) => -314159))) + + (test-case "char input" + (let* ((input "the quick brown fox jumped over the lazy dog") + (brd (open-buffered-reader (open-input-u8vector (string->utf8 input))))) + (for (char (string->list input)) + (check (BufferedReader-read-char brd) => char)) + (check (BufferedReader-read-char brd) ? eof-object?))) + + (test-case "string input" + (let* ((input "the quick brown fox jumped over the lazy dog") + (brd (open-buffered-reader (open-input-u8vector (string->utf8 input)))) + (buf (make-string 16))) + (for (i (in-range (fx/ (fx+ (string-length input) 15) 16))) + (let* ((expected-chars (min 16 (fx- (string-length input) (* i 16)))) + (expected-output (substring input (* i 16) (+ (* i 16) expected-chars)))) + (check (BufferedReader-read-string brd buf) => expected-chars) + (check (substring buf 0 expected-chars) => expected-output))))) + + (test-case "line input" + (let ((input1 "the quick brown fox jumped over the lazy dog") + (input2 "the quick brown fox jumped over the lazy dog\n") + (input3 "the quick brown fox jumped over the lazy dog\r\n")) + (let (brd (open-buffered-reader (open-input-u8vector (string->utf8 input1)))) + (check (BufferedReader-read-line brd) => input1)) + (let (brd (open-buffered-reader (open-input-u8vector (string->utf8 input2)))) + (check (BufferedReader-read-line brd) => input1)) + (let (brd (open-buffered-reader (open-input-u8vector (string->utf8 input2)))) + (check (BufferedReader-read-line brd #\newline #t) => input2)) + (let (brd (open-buffered-reader (open-input-u8vector (string->utf8 input3)))) + (check (BufferedReader-read-line brd '(#\return #\newline)) => input1)) + (let (brd (open-buffered-reader (open-input-u8vector (string->utf8 input3)))) + (check (BufferedReader-read-line brd '(#\return #\newline) #t) => input3)))))) + +(def binary-output-port-test + (test-suite "buffered writer" + (test-case "u8vector output" + (let* ((u8v (make-test-u8vector 1024)) + (port (open-output-u8vector)) + (bwr (open-buffered-writer port 128))) + (for (i (in-range 16)) + (check (BufferedWriter-write bwr u8v (* i 64) (* (+ i 1) 64)) => 64)) + (BufferedWriter-close bwr) + (check (get-output-u8vector port) => u8v))) + + (test-case "u8 output" + (let* ((u8v (make-test-u8vector 1024)) + (port (open-output-u8vector)) + (bwr (open-buffered-writer port 128))) + (for (i (in-range 1024)) + (check (BufferedWriter-write-u8 bwr (u8vector-ref u8v i)) => 1)) + (BufferedWriter-close bwr) + (check (get-output-u8vector port) => u8v))) + + (test-case "integer output" + (let* ((u8v (u8vector + ;; u16 + #x01 #x02 + ;; u32 + #x01 #x02 #x03 #x04 + ;; u64 + #x01 #x02 #x03 #x04 #x05 #x06 #x07 #x08 + ;; s16 + #x01 #x02 + #x81 #x02 + ;; s32 + #x01 #x02 #x03 #x04 + #x81 #x02 #x03 #x04 + ;; s64 + #x01 #x02 #x03 #x04 #x05 #x06 #x07 #x08 + #x81 #x02 #x03 #x04 #x05 #x06 #x07 #x08 + ;; varuint + #xaf #x96 #x13 + ;; varint + #xde #xac #x26 + #xdd #xac #x26 + )) + (port (open-output-u8vector)) + (bwr (open-buffered-writer port))) + (check (BufferedWriter-write-u16 bwr #x0102) => 2) + (check (BufferedWriter-write-u32 bwr #x01020304) => 4) + (check (BufferedWriter-write-u64 bwr #x0102030405060708) => 8) + (check (BufferedWriter-write-s16 bwr #x0102) => 2) + (check (BufferedWriter-write-s16 bwr -32510) => 2) + (check (BufferedWriter-write-s32 bwr #x01020304) => 4) + (check (BufferedWriter-write-s32 bwr -2130574588) => 4) + (check (BufferedWriter-write-s64 bwr #x0102030405060708) => 8) + (check (BufferedWriter-write-s64 bwr -9150748177064392952) => 8) + (check (BufferedWriter-write-varuint bwr 314159) => 3) + (check (BufferedWriter-write-varint bwr 314159) => 3) + (check (BufferedWriter-write-varint bwr -314159) => 3) + (BufferedWriter-close bwr) + (check (get-output-u8vector port) => u8v))) + + (test-case "char output" + (let* ((input "the quick brown fox jumped over the lazy dog") + (output (string->utf8 input)) + (port (open-output-u8vector)) + (bwr (open-buffered-writer port))) + (for (char (string->list input)) + (check (BufferedWriter-write-char bwr char) => 1)) + (BufferedWriter-close bwr) + (check (get-output-u8vector port) => output))) + + (test-case "string output" + (let* ((input "the quick brown fox jumped over the lazy dog") + (output (string->utf8 input)) + (port (open-output-u8vector)) + (bwr (open-buffered-writer port))) + (for (i (in-range (fx/ (fx+ (string-length input) 15) 16))) + (let* ((input-start (* i 16)) + (input-end (fxmin (* (+ i 1) 16) (string-length input))) + (expected-chars (fx- input-end input-start))) + (check (BufferedWriter-write-string bwr input input-start input-end) => expected-chars))) + (BufferedWriter-close bwr) + (check (get-output-u8vector port) => output))) + + (test-case "line output" + (let ((input "the quick brown fox jumped over the lazy dog") + (output1 (string->utf8 "the quick brown fox jumped over the lazy dog\n")) + (output2 (string->utf8 "the quick brown fox jumped over the lazy dog\r\n"))) + (let* ((port (open-output-u8vector)) + (bwr (open-buffered-writer port))) + (check (BufferedWriter-write-line bwr input) => (fx+ (string-length input) 1)) + (BufferedWriter-close bwr) + (check (get-output-u8vector port) => output1)) + (let* ((port (open-output-u8vector)) + (bwr (open-buffered-writer port))) + (check (BufferedWriter-write-line bwr input '(#\return #\newline)) => (fx+ (string-length input) 2)) + (check (get-output-u8vector port) => output2)))))) + +(def textual-input-port-test + (test-suite "buffered string reader" + (test-case "string input" + (let* ((str (make-test-string 1024)) + (port (open-input-string str)) + (brd (open-buffered-string-reader port)) + (buf (make-string 64))) + (for (i (in-range 16)) + (check (BufferedStringReader-read-string brd buf) => 64) + (for (j (in-range 64)) + (check (string-ref buf j) => (integer->char (modulo (+ (* i 64) j) 256))))) + (check (BufferedStringReader-read-string brd buf) => 0) + (check-exception (BufferedStringReader-read-string brd buf 0 64 1) io-error?) + (check-exception (BufferedStringReader-read-string brd buf 0 64 30) io-error?) + (check-exception (BufferedStringReader-read-string brd buf 0 64 64) io-error?))) + + (test-case "char input" + (let* ((str (make-test-string 1024)) + (port (open-input-string str)) + (brd (open-buffered-string-reader port))) + (for (i (in-range 1024)) + (check (BufferedStringReader-peek-char brd) => (integer->char (modulo i 256))) + (check (BufferedStringReader-read-char brd) => (integer->char (modulo i 256)))) + (check (BufferedStringReader-peek-char brd) ? eof-object?) + (check (BufferedStringReader-read-char brd) ? eof-object?))) + + (test-case "input skipping" + (let* ((str (make-test-string 1024)) + (port (open-input-string str)) + (brd (open-buffered-string-reader port)) + (buf (make-string 64))) + (BufferedStringReader-skip brd 3) + (check (BufferedStringReader-read-string brd buf) => 64) + (for (i (in-range 64)) + (check (string-ref buf i) => (integer->char (modulo (+ i 3) 256)))) + (BufferedStringReader-skip brd 950) + (string-fill! buf (integer->char 0)) + (check (BufferedStringReader-read-string brd buf) => 7) + (for (i (in-range 7)) + (check (string-ref buf i) => (integer->char (modulo (+ 1017 i) 256)))) + (for (i (in-range 7 64)) + (check (string-ref buf i) => (integer->char 0))))) + + (test-case "input delimiting" + (let* ((str (make-test-string 1024)) + (port (open-input-string str)) + (brd (open-buffered-string-reader port)) + (buf (make-string 64))) + (BufferedStringReader-skip brd 7) + (let (dbrd (BufferedStringReader-delimit brd 10)) + (check (BufferedStringReader-read-string dbrd buf) => 10) + (for (i (in-range 10)) + (check (string-ref buf i) => (integer->char (+ 7 i)))) + (for (i (in-range 10 64)) + (check (string-ref buf i) => (integer->char 0))) + (check (BufferedStringReader-read-string dbrd buf) => 0)) + (check (BufferedStringReader-read-string brd buf) => 64) + (for (i (in-range 64)) + (check (string-ref buf i) => (integer->char (modulo (+ 17 i) 256)))))) + + (test-case "line input" + (let ((input1 "the quick brown fox jumped over the lazy dog") + (input2 "the quick brown fox jumped over the lazy dog\n") + (input3 "the quick brown fox jumped over the lazy dog\r\n")) + (let (brd (open-buffered-string-reader (open-input-string input1))) + (check (BufferedStringReader-read-line brd) => input1)) + (let (brd (open-buffered-string-reader (open-input-string input2))) + (check (BufferedStringReader-read-line brd) => input1)) + (let (brd (open-buffered-string-reader (open-input-string input2))) + (check (BufferedStringReader-read-line brd #\newline #t) => input2)) + (let (brd (open-buffered-string-reader (open-input-string input3))) + (check (BufferedStringReader-read-line brd '(#\return #\newline)) => input1)) + (let (brd (open-buffered-string-reader (open-input-string input3))) + (check (BufferedStringReader-read-line brd '(#\return #\newline) #t) => input3)))))) + +(def textual-output-port-test + (test-suite "buffered string writer" + (test-case "string output" + (let* ((str (make-test-string 1024)) + (port (open-output-string)) + (bwr (open-buffered-string-writer port))) + (for (i (in-range 16)) + (check (BufferedStringWriter-write-string bwr str (* i 64) (* (+ i 1) 64)) => 64)) + (BufferedStringWriter-close bwr) + (check (get-output-string port) => str))) + + (test-case "char output" + (let* ((str (make-test-string 1024)) + (port (open-output-string)) + (bwr (open-buffered-string-writer port))) + (for (i (in-range 1024)) + (check (BufferedStringWriter-write-char bwr (string-ref str i)) => 1)) + (BufferedStringWriter-close bwr) + (check (get-output-string port) => str))) + + (test-case "line output" + (let ((input "the quick brown fox jumped over the lazy dog") + (output1 "the quick brown fox jumped over the lazy dog\n") + (output2 "the quick brown fox jumped over the lazy dog\r\n")) + (let* ((port (open-output-string)) + (bwr (open-buffered-string-writer port))) + (check (BufferedStringWriter-write-line bwr input) => (fx+ (string-length input) 1)) + (BufferedStringWriter-close bwr) + (check (get-output-string port) => output1)) + (let* ((port (open-output-string)) + (bwr (open-buffered-string-writer port))) + (check (BufferedStringWriter-write-line bwr input '(#\return #\newline)) => (fx+ (string-length input) 2)) + (check (get-output-string port) => output2)))))) diff --git a/src/std/io/port.ss b/src/std/io/port.ss index 01263f6b9..5b7209ab0 100644 --- a/src/std/io/port.ss +++ b/src/std/io/port.ss @@ -1,45 +1,374 @@ (import :gerbil/gambit - :std/sugar) + :std/sugar + :std/error + ./interface) -(export raw-port raw-port-port) +(export make-raw-input-port raw-input-port? + make-raw-output-port raw-output-port? + make-raw-binary-input-port raw-binary-input-port? + make-raw-textual-input-port raw-textual-input-port? + make-raw-binary-output-port raw-binary-output-port? + make-raw-textual-output-port raw-textual-output-port? + make-cooked-binary-input-port cooked-binary-input-port? + make-cooked-textual-input-port cooked-textual-input-port?) + +(declare (not safe)) ;; Raw wrapper for a port without any buffering -(defstruct raw-port (port) final: #t unchecked: #t) +(defstruct raw-port (port) unchecked: #t) +(defstruct (raw-input-port raw-port) ()) +(defstruct (raw-output-port raw-port) ()) +(defstruct (raw-binary-input-port raw-input-port) ()) +(defstruct (raw-textual-input-port raw-input-port) ()) +(defstruct (raw-binary-output-port raw-output-port) ()) +(defstruct (raw-textual-output-port raw-output-port) ()) + +;; Cooked ports +(defstruct cooked-buffer (buffer lo hi) unchecked: #t final: #t) +(defstruct (cooked-port raw-port) (buffer) unchecked: #t) ; phantom type for accessor +(defstruct (cooked-binary-input-port raw-input-port) (buffer) final: #t + constructor: :init!) +(defstruct (cooked-textual-input-port raw-input-port) (buffer) final: #t + constructor: :init!) + +;; delimited input +(defstruct delimited (e limit) unchecked: #t) +(defstruct (delimited-binary-input-port delimited) () final: #t) +(defstruct (delimited-textual-input-port delimited) () final: #t) + +(defrules defport-method (=>) + ((_ klass (name port args ...) => primitive) + (defmethod {name klass} + (lambda (self args ...) + (let (port (&raw-port-port self)) + (primitive args ... port))))) + ((_ klass (name port args ...) body ...) + (defmethod {name klass} + (lambda (self args ...) + (let (port (&raw-port-port self)) + body ...))))) -(defrule (def-raw-port-method (name port . args) body ...) - (defmethod {name raw-port} +(defrule (defcooked-port-method klass (name port buffer . args) body ...) + (defmethod {name klass} (lambda (self . args) - (let (port (&raw-port-port self)) + (let ((port (&raw-port-port self)) + (buffer (&cooked-port-buffer self))) body ...)))) -(def-raw-port-method (close port) - (close-port port)) -(def-raw-port-method (read-char port) - (read-char port)) -(def-raw-port-method (peek-char port) - (peek-char port)) -(def-raw-port-method (read port u8v (start 0) (end (u8vector-length u8v)) (need 0)) - (read-subu8vector u8v port start end need)) -(def-raw-port-method (write port u8v (start 0) (end (u8vector-length u8v))) - (write-subu8vector u8v port start end)) -(def-raw-port-method (read-u8 port) - (read-u8 port)) -(def-raw-port-method (peek-u8 port) - (peek-u8 port)) -(def-raw-port-method (put-back port previous-input) - (error "cannot put-back into port" port previous-input)) -(def-raw-port-method (skip port count) - (error "cannot skip from port" port count)) -(def-raw-port-method (delimit port limit) - (error "cannot delimit port" port limit)) -(def-raw-port-method (reset! port reader) - (error "cannot reset! port" port reader)) -(def-raw-port-method (write-u8 port u8) - (write-u8 u8 port)) -(def-raw-port-method (flush port) - (force-output port)) -(def-raw-port-method (read-string port str (start 0) (end (string-length str)) (need 0)) - (read-substring str start end port need)) -(def-raw-port-method (write-string port str (start 0) (end (string-length str))) - (write-substring str start end port)) +(defrule (defsimple-port-method klass (name self . args) body ...) + (defmethod {name klass} + (lambda (self . args) + body ...))) + +(defport-method raw-port (close port) + => close-port) +(defport-method raw-port (reset! port reader) + (raise-unsupported-method reset!)) + +(defport-method raw-input-port (close port) + => close-input-port) + +(defport-method raw-binary-input-port (read port u8v start end need) + (let (rd (read-subu8vector u8v start end port need)) + (if (fx< rd need) + (raise-premature-end-of-input raw-binary-input-port) + rd))) +(defport-method raw-binary-input-port (read-u8 port) + => read-u8) +(defport-method raw-binary-input-port (peek-u8 port) + => peek-u8) + +(defport-method raw-textual-input-port (read-string port str start end need) + (let (rd (read-substring str start end port need)) + (if (fx< rd need) + (raise-premature-end-of-input raw-binary-input-port) + rd))) +(defport-method raw-textual-input-port (read-char port) + => read-char) +(defport-method raw-textual-input-port (peek-char port) + => peek-char) + +(defport-method raw-output-port (close port) + => close-output-port) +(defport-method raw-output-port (flush port) + => force-output) +(defport-method raw-binary-output-port (write port u8v start end) + (write-subu8vector u8v start end port) + (fx- end start)) +(defport-method raw-binary-output-port (write-u8 port u8) + (write-u8 u8 port) 1) +(defport-method raw-textual-output-port (write-string port str start end) + (write-substring str start end port) + (fx- end start)) +(defport-method raw-textual-output-port (write-char port char) + (write-char char port) 1) + +(def (cooked-port-init! self port) + (set! (&raw-port-port self) port) + (set! (&cooked-port-buffer self) (make-cooked-buffer #f 0 0))) + +;;; Cooked Binary Input +(defmethod {:init! cooked-binary-input-port} + cooked-port-init!) + +(defcooked-port-method cooked-binary-input-port (put-back port buffer previous-input) + (cooked-buffer-put-back! buffer previous-input u8vector-set! u8vector-length make-u8vector subu8vector-move!)) + +(defcooked-port-method cooked-binary-input-port (skip port buffer count) + (cooked-input-port-skip! port buffer count read-u8)) + +(defsimple-port-method cooked-binary-input-port (delimit self limit) + (BufferedReader (make-delimited-binary-input-port self limit))) + +(defcooked-port-method cooked-binary-input-port (read-u8 port buffer) + (cooked-input-port-read1 port buffer read-u8 u8vector-ref)) + +(defcooked-port-method cooked-binary-input-port (peek-u8 port buffer) + (cooked-input-port-peek port buffer peek-u8 u8vector-ref)) + +(defcooked-port-method cooked-binary-input-port (read port buffer u8v start end need) + (cooked-input-port-read* port buffer u8v start end need read-subu8vector subu8vector-move!)) + +;;; Delimited Binary Input +(defsimple-port-method delimited-binary-input-port (close self) + (delimited-close! self)) + +(defsimple-port-method delimited-binary-input-port (reset! self) + (raise-unsupported-method reset!)) + +(defsimple-port-method delimited-binary-input-port (put-back self previous-input) + (delimited-put-back! self previous-input cooked-binary-input-port::put-back)) + +(defsimple-port-method delimited-binary-input-port (skip self count) + (delimited-skip! self count cooked-binary-input-port::skip)) + +(defsimple-port-method delimited-binary-input-port (delimit self limit) + (BufferedReader (make-delimited-binary-input-port self limit))) + +(defsimple-port-method delimited-binary-input-port (peek-u8 self) + (delimited-peek self cooked-binary-input-port::peek-u8)) + +(defsimple-port-method delimited-binary-input-port (read-u8 self) + (delimited-read1 self cooked-binary-input-port::read-u8)) + +(defsimple-port-method delimited-binary-input-port (read self u8v start end need) + (delimited-read* self u8v start end need cooked-binary-input-port::read)) + +;;; Cooked Textual Input +(defmethod {:init! cooked-textual-input-port} + cooked-port-init!) + +(defcooked-port-method cooked-textual-input-port (put-back port buffer previous-input) + (cooked-buffer-put-back! buffer previous-input string-set! string-length make-string substring-move!)) + +(defcooked-port-method cooked-textual-input-port (skip port buffer count) + (cooked-input-port-skip! port buffer count read-char)) + +(defsimple-port-method cooked-textual-input-port (delimit self limit) + (BufferedStringReader (make-delimited-textual-input-port self limit))) + +(defcooked-port-method cooked-textual-input-port (read-char port buffer) + (cooked-input-port-read1 port buffer read-char string-ref)) + +(defcooked-port-method cooked-textual-input-port (peek-char port buffer) + (cooked-input-port-peek port buffer peek-char string-ref)) + +(defcooked-port-method cooked-textual-input-port (read-string port buffer str start end need) + (cooked-input-port-read* port buffer str start end need read-substring substring-move!)) + +;;; Delimited Textual Input +(defsimple-port-method delimited-textual-input-port (close self) + (delimited-close! self)) + +(defsimple-port-method delimited-textual-input-port (reset! self) + (raise-unsupported-method reset!)) + +(defsimple-port-method delimited-textual-input-port (put-back self previous-input) + (delimited-put-back! self previous-input cooked-textual-input-port::put-back)) + +(defsimple-port-method delimited-textual-input-port (skip self count) + (delimited-skip! self count cooked-textual-input-port::skip)) + +(defsimple-port-method delimited-textual-input-port (delimit self limit) + (BufferedStringReader (make-delimited-textual-input-port self limit))) + +(defsimple-port-method delimited-textual-input-port (peek-char self) + (delimited-peek self cooked-textual-input-port::peek-char)) + +(defsimple-port-method delimited-textual-input-port (read-char self) + (delimited-read1 self cooked-textual-input-port::read-char)) + +(defsimple-port-method delimited-textual-input-port (read-string self str start end need) + (delimited-read* self str start end need cooked-textual-input-port::read-string)) + +;;; Cooked Port Utilities +(def (cooked-buffer-consume! buffer n) + (let (lo (fx+ (&cooked-buffer-lo buffer))) + (if (fx< lo (&cooked-buffer-hi buffer)) + (set! (&cooked-buffer-lo buffer) lo) + (begin + (set! (&cooked-buffer-lo buffer) 0) + (set! (&cooked-buffer-hi buffer) 0))))) + +(def (cooked-buffer-skip! buffer to-skip) + (let* ((lo (&cooked-buffer-lo buffer)) + (hi (&cooked-buffer-hi buffer)) + (have (fx- hi lo))) + (if (fx< have to-skip) + (begin + (cooked-buffer-consume! buffer have) + have) + (begin + (cooked-buffer-consume! buffer to-skip) + to-skip)))) + +(def (cooked-port-skip! port skip read-e) + (let lp ((to-skip skip)) + (when (fx> to-skip 0) + (read-e port) + (lp (fx- to-skip 1))))) + +(defrule (cooked-input-port-skip! port buffer count read-e) + (let (skipped (cooked-buffer-skip! buffer count)) + (when (fx< skipped count) + (cooked-port-skip! port (fx- count skipped) read-e) + (void)))) + +(defrule (cooked-input-port-read1 port buffer read-e buffer-ref) + (if (&cooked-buffer-buffer buffer) + (if (fx< (&cooked-buffer-lo buffer) (&cooked-buffer-hi buffer)) + (let (char (buffer-ref (&cooked-buffer-buffer buffer) (&cooked-buffer-lo buffer))) + (cooked-buffer-consume! buffer 1) + char) + (read-e port)) + (read-e port))) + +(defrule (cooked-input-port-peek port buffer peek-e buffer-ref) + (if (&cooked-buffer-buffer buffer) + (if (fx< (&cooked-buffer-lo buffer) (&cooked-buffer-hi buffer)) + (buffer-ref (&cooked-buffer-buffer buffer) (&cooked-buffer-lo buffer)) + (peek-e port)) + (peek-e port))) + +(defrules cooked-input-port-read* () + ((macro port buffer obj start end need read-e buffer-move!) + (if buffer + (let ((lo (&cooked-buffer-lo buffer)) + (hi (&cooked-buffer-hi buffer))) + (if (fx< lo hi) + (let ((want (fx- end start)) + (have (fx- hi lo))) + (cond + ((fx< have want) + (buffer-move! (&cooked-buffer-buffer buffer) lo hi obj start) + (let (rd (read-e obj (fx+ start have) end port (fxmax (fx- need have) 0))) + (cooked-buffer-consume! buffer have) + (fx+ have rd))) + (else + (buffer-move! (&cooked-buffer-buffer buffer) lo (fx+ lo want) obj start) + (cooked-buffer-consume! buffer want) + want))) + (let (rd (read-e obj start end port need)) + (if (fx< rd need) + (raise-premature-end-of-input macro) + rd)))) + (let (rd (read-e obj start end port need)) + (if (fx< rd need) + (raise-premature-end-of-input macro) + rd))))) + +(defrule (cooked-buffer-put-back! buffer previous-input buffer-set! buffer-length make-buffer buffer-move!) + (let recur ((buf (&cooked-buffer-buffer buffer)) (previous-input previous-input)) + (if buffer + (if (pair? previous-input) + (for-each (lambda (previous-input) (recur buf previous-input)) previous-input) + (let ((lo (&cooked-buffer-lo buffer)) + (hi (&cooked-buffer-hi buffer))) + (cond + ((fx< hi (buffer-length buf)) + (buffer-set! buf hi previous-input) + (set! (&cooked-buffer-hi buffer) (fx+ hi 1))) + ((fx> lo 0) + (buffer-move! buf lo hi buf 0) + (buffer-set! buf (fx- hi lo) previous-input)) + (else + (let (newbuf (make-buffer (fx* 2 (buffer-length buf)))) + (buffer-move! buf lo hi newbuf 0) + (buffer-set! newbuf hi previous-input) + (set! (&cooked-buffer-buffer buffer) newbuf)))))) + (let (buf (make-buffer 64)) + (set! (&cooked-buffer-buffer buffer) buf) + (recur buf previous-input))))) + +(defrule (delimited-close! self) + (let recur ((obj self)) + (if (delimited? obj) + (recur (&delimited-e obj)) + (close-port (&raw-port-port obj))))) + +(defrule (delimited-put-back! self previous-input put-back-e) + (let recur ((obj self)) + (if (delimited? obj) + (begin + (set! (&delimited-limit obj) + (fx+ (&delimited-limit obj) + (if (pair? previous-input) + (length previous-input) + 1))) + (recur (&delimited-e obj))) + (put-back-e obj previous-input)))) + +(defrules delimited-skip! () + ((macro self count skip-e) + (let recur ((obj self) (count count)) + (if (delimited? obj) + (let (limit (&delimited-limit obj)) + (if (fx<= count limit) + (begin + (recur (&delimited-e obj) count) + (set! (&delimited-limit obj) + (fx- limit count))) + (raise-io-error macro "input limit exceeded" count limit))) + (skip-e obj count))))) + +(defrule (delimited-peek self peek-e) + (let recur ((obj self)) + (if (delimited? obj) + (if (fx> (&delimited-limit obj) 0) + (recur (&delimited-e obj)) + '#!eof) + (peek-e obj)))) + +(defrule (delimited-read1 self read-e) + (let recur ((obj self)) + (if (delimited? obj) + (let (limit (&delimited-limit obj)) + (if (fx> limit 0) + (let (result (recur (&delimited-e obj))) + (set! (&delimited-limit obj) (fx- limit 1)) + result) + '#!eof)) + (read-e obj)))) + +(defrules delimited-read* () + ((macro self buf start end need read-e) + (let recur ((obj self) (end end)) + (if (delimited? obj) + (let ((limit (&delimited-limit obj)) + (want (fx- end start))) + (cond + ((fx> need limit) + (raise-io-error macro "input limit exceeded" need limit)) + ((fx<= want limit) + (let (rd (recur (&delimited-e obj) end)) + (set! (&delimited-limit obj) (fx- limit rd)) + rd)) + (else + (let (rd (recur (&delimited-e obj) (fx+ start limit))) + (set! (&delimited-limit obj) (fx- limit rd)) + rd)))) + (let (rd (read-e obj buf start end need)) + (if (fx< rd need) + (raise-premature-end-of-input macro) + rd)))))) diff --git a/src/std/io/strio/api.ss b/src/std/io/strio/api.ss index 07782f94e..e6ca6c814 100644 --- a/src/std/io/strio/api.ss +++ b/src/std/io/strio/api.ss @@ -98,7 +98,7 @@ (character-decoder codec) #f))) ((input-port? pre-reader) - (StringReader (raw-port pre-reader))) ;; TODO: use a cooked-port instead + (StringReader (make-raw-textual-input-port pre-reader))) (else (raise-bad-argument open-string-reader "implementation of Reader" pre-reader)))) @@ -127,7 +127,7 @@ (character-encoder codec) #f))) ((output-port? pre-writer) - (StringWriter (raw-port pre-writer))) ;; TODO: use a cooked-port instead + (StringWriter (make-raw-textual-output-port pre-writer))) (else (raise-bad-argument open-string-writer "implementation of Writer" pre-writer)))) @@ -153,7 +153,7 @@ (make-string-buffer buffer-or-size) 0 0 #f))) ((input-port? pre-reader) - (BufferedStringReader (raw-port pre-reader))) ;; TODO: use a cooked-port instead + (BufferedStringReader (make-cooked-textual-input-port pre-reader))) (else (raise-bad-argument open-buffered-string-reader "string or implementation of StringReader or Reader" pre-reader)))) @@ -179,7 +179,7 @@ (make-string-buffer buffer-or-size) 0 #f))) ((output-port? pre-writer) - (BufferedStringWriter (raw-port pre-writer))) ;; TODO: use a cooked-port instead + (BufferedStringWriter (make-raw-textual-output-port pre-writer))) (else (raise-bad-argument open-buffered-string-writer "#f or implementation of StringWriter or writer" pre-writer)))) diff --git a/src/std/text/basic-parsers.ss b/src/std/text/basic-parsers.ss index 15476b1f5..0848fcd12 100644 --- a/src/std/text/basic-parsers.ss +++ b/src/std/text/basic-parsers.ss @@ -157,7 +157,7 @@ ;; Parse an entire port (def (parse-port parser port (description port) (where 'parse-port)) - (parse-reader parser (PeekableStringReader (raw-port port)) description where)) + (parse-reader parser (PeekableStringReader (make-raw-input-port port)) description where)) ;; Parse an entire file (def (parse-file parser file (description file) (where 'parse-file))