diff --git a/lab/io-prims.ss b/lab/io-prims.ss deleted file mode 100644 index 58a6bdf..0000000 --- a/lab/io-prims.ss +++ /dev/null @@ -1,9 +0,0 @@ - -(library (io-prims) - (export ) - (import - (io-spec) - (except (ikarus))) - - - ) diff --git a/lab/io-spec.ss b/lab/io-spec.ss index 1f0cd9d..94199a3 100644 --- a/lab/io-spec.ss +++ b/lab/io-spec.ss @@ -1,28 +1,41 @@ (library (io-spec) - (export ) + (export + input-port? textual-port? port-eof? + open-bytevector-input-port + make-custom-binary-input-port + get-char lookahead-char get-u8 lookahead-u8 close-port) (import - (except (ikarus) get-char get-u8 put-char put-u8)) + (except (ikarus) + input-port? textual-port? port-eof? + open-bytevector-input-port + make-custom-binary-input-port + get-char lookahead-char get-u8 lookahead-u8 close-port)) (define-struct $port - (index size buffer base-index codec closed? handlers attrs)) + (index size buffer base-index codec closed? attrs + id read! write! get-position set-position! close)) (define $set-port-index! set-$port-index!) + (define $set-port-size! set-$port-size!) + (define $set-port-attrs! set-$port-attrs!) + (define $set-port-closed?! set-$port-closed?!) + (define $make-port make-$port) - (define fast-get-tag #x0001) - (define fast-put-tag #x0002) + (define fast-get-tag #x0001) + (define fast-put-tag #x0002) (define fast-get-position-tag #x0004) - (define fast-get-mask #x00F0) - (define fast-get-utf8-tag #x0010) - (define fast-get-latin-tag #x0030) - (define fast-get-byte-tag #x0040) - (define fast-get-char-tag #x0080) + (define fast-get-mask #x00F0) + (define fast-get-utf8-tag #x0010) + (define fast-get-latin-tag #x0030) + (define fast-get-byte-tag #x0040) + (define fast-get-char-tag #x0080) - (define fast-put-mask #x0F00) - (define fast-put-utf8-tag #x0100) - (define fast-put-latin-tag #x0300) - (define fast-put-byte-tag #x0400) - (define fast-put-char-tag #x0800) + (define fast-put-mask #x0F00) + (define fast-put-utf8-tag #x0100) + (define fast-put-latin-tag #x0300) + (define fast-put-byte-tag #x0400) + (define fast-put-char-tag #x0800) (define r6rs-mode-tag #x1000) @@ -38,8 +51,82 @@ ;;; everything above this line will turn into primitive ;;; ---------------------------------------------------------- - (define-struct handler - (data id read! write! get-position set-position! close)) + + + (define ($make-custom-binary-input-port id + read! get-position set-position! close buffer-size) + (let ([bv (make-bytevector buffer-size)]) + ($make-port 0 0 bv 0 #f #f 0 id read! #f get-position + set-position! close))) + + (define (make-custom-binary-input-port id + read! get-position set-position! close) + ;;; FIXME: get-position and set-position! are ignored for now + (define who 'make-custom-binary-input-port) + (unless (string? id) + (error who "id is not a string" id)) + (unless (procedure? read!) + (error who "read! is not a procedure" read!)) + (unless (or (procedure? close) (not close)) + (error who "close should be either a procedure or #f" close)) + ($make-custom-binary-input-port id read! get-position + set-position! close 256)) + + (define (transcoder-attrs x) + (import (ikarus system $transcoders)) + (cond + [(not x) ;;; binary + (fxior fast-get-tag fast-get-byte-tag)] + [else + (error 'transcoder-attrs "not handled" x)])) + + + (define open-bytevector-input-port + (case-lambda + [(bv) (open-bytevector-input-port bv #f)] + [(bv maybe-transcoder) + (import (ikarus system $transcoders)) + (unless (bytevector? bv) + (error 'open-bytevector-input-port + "not a bytevector" bv)) + (when (and maybe-transcoder + (not ($transcoder? maybe-transcoder))) + (error 'open-bytevector-input-port + "not a transcoder" maybe-transcoder)) + ($make-port 0 (bytevector-length bv) bv 0 + maybe-transcoder + #f ;;; closed? + (transcoder-attrs maybe-transcoder) + "*bytevector-input-port*" + (lambda (bv i c) 0) ;;; read! + #f ;;; write! + #f ;;; FIXME: get-position + #f ;;; FIXME: set-position! + #f ;;; close + )])) + + (define (input-port? p) + (and ($port? p) + ($port-read! p) + #t)) + + (define (textual-port? p) + (and ($port? p) + ($port-codec p) + #t)) + + (define (close-port p) + (cond + [(not ($port? p)) + (error 'close-port "not a port" p)] + [($port-closed? p) (void)] + [else + (when ($port-write! p) + (flush-output-port p)) + ($set-port-closed?! p #t) + (let ([close ($port-close p)]) + (when (procedure? close) + (close)))])) (define-syntax define-rrr (syntax-rules () @@ -48,11 +135,12 @@ (error 'name "not implemented" args))])) ;;; ---------------------------------------------------------- - (module (get-char) + (module (get-char lookahead-char) (define-rrr get-char-utf8-mode) (define-rrr get-char-latin-mode) (define-rrr get-char-char-mode) (define-rrr slow-get-char) + (define-rrr lookahead-char) ;;; (define (get-char p) (define who 'get-char) @@ -90,9 +178,35 @@ [else (slow-get-char p who)])))) ;;; ---------------------------------------------------------- - (module (get-u8) - (define-rrr get-u8-byte-mode) - (define-rrr slow-get-u8) + (define (assert-binary-input-port p who) + (unless ($port? p) (error who "not a port" p)) + (when ($port-closed? p) (error who "port is closed" p)) + (when ($port-codec p) (error who "port is not binary" p)) + (unless ($port-read! p) + (error who "port is not an input port" p))) + + (module (get-u8 lookahead-u8) + (define (get-u8-byte-mode p who start) + (when ($port-closed? p) (error who "port is closed" p)) + (let* ([bv ($port-buffer p)] + [n (bytevector-length bv)]) + (let ([j (($port-read! p) bv 0 n)]) + (unless (fixnum? j) + (error who "invalid return value from read! procedure" j)) + (cond + [(fx> j 0) + (unless (fx<= j n) + (error who "read! returned a value out of range" j)) + ($set-port-index! p start) + ($set-port-size! p j) + (bytevector-u8-ref bv 0)] + [(fx= j 0) (eof-object)] + [else + (error who "read! returned a value out of range" j)])))) + (define (slow-get-u8 p who start) + (assert-binary-input-port p who) + ($set-port-attrs! p (fxior fast-get-tag fast-get-byte-tag)) + (get-u8-byte-mode p who start)) ;;; (define (get-u8 p) (define who 'get-u8) @@ -104,9 +218,49 @@ [(fx< i ($port-size p)) ($set-port-index! p (fx+ i 1)) (bytevector-u8-ref ($port-buffer p) i)] - [else (get-u8-byte-mode p who)]))] - [else (slow-get-u8 p who)])))) + [else (get-u8-byte-mode p who 1)]))] + [else (slow-get-u8 p who 1)]))) + (define (lookahead-u8 p) + (define who 'lookahead-u8) + (let ([m ($port-get-mode p)]) + (cond + [(eq? m fast-get-byte-tag) + (let ([i ($port-index p)]) + (cond + [(fx< i ($port-size p)) + (bytevector-u8-ref ($port-buffer p) i)] + [else (get-u8-byte-mode p who 0)]))] + [else (slow-get-u8 p who 0)])))) + (define (port-eof? p) + (define who 'port-eof?) + (let ([m ($port-get-mode p)]) + (cond + [(not (eq? m 0)) + (if (fx< ($port-index p) ($port-size p)) + #f + (if ($port-codec p) + (eof-object? (lookahead-char p)) + (eof-object? (lookahead-u8 p))))] + [(input-port? p) + (when ($port-closed? p) + (error 'port-eof? "port is closed" p)) + (if (textual-port? p) + (eof-object? (lookahead-char p)) + (eof-object? (lookahead-u8 p)))] + [else (error 'port-eof? "not an input port" p)]))) + + + + ) + + + +#!eof + + ;;; ---------------------------------------------------------- + ;;; do input ports first. + ;;; ---------------------------------------------------------- (module (put-char) (define-rrr put-char-utf8-mode) @@ -147,7 +301,6 @@ (put-char-latin-mode p b who)])))] [else (slow-put-char p c who)])))) - ;;; ---------------------------------------------------------- (module (put-u8) (define-rrr put-u8-byte-mode) (define-rrr slow-put-u8) @@ -166,7 +319,3 @@ [else (put-u8-byte-mode p b who)]))] [else (slow-put-u8 p b who)])))) - - ;;; that's it for today. see you tomorrow . - - ) diff --git a/lab/io-test.ss b/lab/io-test.ss new file mode 100755 index 0000000..b9af090 --- /dev/null +++ b/lab/io-test.ss @@ -0,0 +1,108 @@ +#!/usr/bin/env scheme-script + +(import + (except (ikarus) get-char get-u8 lookahead-u8 close-port input-port?) + (io-spec)) + +(define-syntax test + (syntax-rules () + [(_ name body) + (begin + (printf "running ~s ..." 'name) + body + (printf " ok\n"))])) + +(define (make-n-byte-custom-binary-input-port n) + (assert (<= 0 n 256)) + (make-custom-binary-input-port "test0" + (let ([c 0]) + (lambda (bv i count) + (if (< c n) + (begin + (bytevector-u8-set! bv i c) + (set! c (+ c 1)) + 1) + 0))) + #f #f #f)) + +(define (make-n-byte-bytevector-binary-input-port n) + (assert (<= 0 n 256)) + (let ([bv (make-bytevector n)]) + (let f ([i 0]) + (unless (= i n) + (bytevector-u8-set! bv i i) + (f (+ i 1)))) + (open-bytevector-input-port bv))) + +(define (test-get-u8-1 p n) + (let f ([i 0]) + (let ([x (get-u8 p)]) + (cond + [(eof-object? x) + (unless (= i n) + (error 'test0 "premature termination" i))] + [(= x i) (f (+ i 1))] + [else + (error 'test0 "incorrect value returned" x)])))) + +(define (test-peek-u8-1 p n) + (let f ([i 0]) + (let* ([px (lookahead-u8 p)] + [x (get-u8 p)]) + (cond + [(not (eqv? px x)) (error #f "peek invalid" px x)] + [(eof-object? x) + (unless (= i n) + (error #f "premature termination" i))] + [(= x i) (f (+ i 1))] + [else + (error #f "incorrect value returned" x i)])))) + +(define (test-port-eof?-1 p n) + (let f ([i 0]) + (cond + [(port-eof? p) + (unless (= i n) + (error #f "premature termination" i)) + (assert (eof-object? (lookahead-u8 p))) + (assert (eof-object? (get-u8 p)))] + [(= (get-u8 p) i) (f (+ i 1))] + [else + (error #f "incorrect value returned" i)]))) + +(test "reading 256 bytes in ascending order" + (test-get-u8-1 (make-n-byte-custom-binary-input-port 256) 256)) + +(test "reading 256 bytes in ascending order 2 at a time" + (test-get-u8-1 + (make-custom-binary-input-port "test0" + (let ([c 0]) + (lambda (bv i count) + (if (< c 256) + (begin + (assert (>= count 2)) + (bytevector-u8-set! bv i c) + (bytevector-u8-set! bv (+ i 1) (+ c 1)) + (set! c (+ c 2)) + 2) + 0))) + #f #f #f) + 256)) + +(test "peeking 256 bytes in ascending order" + (test-peek-u8-1 (make-n-byte-custom-binary-input-port 256) 256)) + +(test "custom-binary-port port-eof?" + (test-port-eof?-1 (make-n-byte-custom-binary-input-port 256) 256)) + +;;; +(test "reading 256 bytes from bytevector-input-port" + (test-get-u8-1 (make-n-byte-bytevector-binary-input-port 256) 256)) + +(test "peeking 256 bytes from bytevector-input-port" + (test-peek-u8-1 (make-n-byte-bytevector-binary-input-port 256) 256)) + +(test "bytevector-binary-port port-eof?" + (test-port-eof?-1 (make-n-byte-bytevector-binary-input-port 256) 256)) + + diff --git a/lab/test-io.ss b/lab/test-io.ss deleted file mode 100755 index c00f394..0000000 --- a/lab/test-io.ss +++ /dev/null @@ -1,6 +0,0 @@ -#!/usr/bin/env scheme-script - -(import - (except (ikarus)) - (io-spec)) - diff --git a/scheme/ikarus.boot.prebuilt b/scheme/ikarus.boot.prebuilt index b1f06b5..0b66925 100644 Binary files a/scheme/ikarus.boot.prebuilt and b/scheme/ikarus.boot.prebuilt differ diff --git a/scheme/ikarus.codecs.ss b/scheme/ikarus.codecs.ss index 0043300..cb886dc 100644 --- a/scheme/ikarus.codecs.ss +++ b/scheme/ikarus.codecs.ss @@ -91,7 +91,7 @@ (define (transcoder-codec x) (define who 'transcoder-codec) - (if ($transcoder? x) + (if (transcoder? x) (let ([tag (fxlogand ($transcoder->data x) codec-mask)]) (or (rev-lookup tag codec-alist) (error who "transcoder has no codec" x))) @@ -99,7 +99,7 @@ (define (transcoder-eol-style x) (define who 'transcoder-eol-style) - (if ($transcoder? x) + (if (transcoder? x) (let ([tag (fxlogand ($transcoder->data x) eol-style-mask)]) (or (rev-lookup tag eol-style-alist) (error who "transcoder has no eol-style" x))) @@ -107,7 +107,7 @@ (define (transcoder-error-handling-mode x) (define who 'transcoder-error-handling-mode) - (if ($transcoder? x) + (if (transcoder? x) (let ([tag (fxlogand ($transcoder->data x) error-handling-mode-mask)]) (or (rev-lookup tag error-handling-mode-alist) (error who "transcoder has no error-handling mode" x))) diff --git a/scheme/ikarus.predicates.ss b/scheme/ikarus.predicates.ss index 573ac3b..57b825c 100644 --- a/scheme/ikarus.predicates.ss +++ b/scheme/ikarus.predicates.ss @@ -22,14 +22,14 @@ symbol? code? not weak-pair? eq? eqv? equal? boolean=? symbol=? finite? infinite? nan? real-valued? rational-valued? integer-valued? - output-port? input-port? port?) + output-port? input-port? port? transcoder?) (import (except (ikarus) fixnum? flonum? bignum? ratnum? number? complex? real? rational? integer? exact? inexact? eof-object? bwp-object? immediate? boolean? char? vector? bytevector? string? procedure? null? pair? weak-pair? symbol? code? not eq? eqv? equal? - port? input-port? output-port? boolean=? symbol=? + transcoder? port? input-port? output-port? boolean=? symbol=? finite? infinite? nan? real-valued? rational-valued? integer-valued?) (ikarus system $fx) @@ -41,6 +41,7 @@ (rename (only (ikarus) fixnum? flonum? bignum? ratnum? eof-object? bwp-object? immediate? boolean? char? vector? string? bytevector? procedure? null? pair? symbol? code? eq? + transcoder? port? input-port? output-port?) (fixnum? sys:fixnum?) (flonum? sys:flonum?) @@ -60,6 +61,7 @@ (symbol? sys:symbol?) (code? sys:code?) (eq? sys:eq?) + (transcoder? sys:transcoder?) (port? sys:port?) (input-port? sys:input-port?) (output-port? sys:output-port?) @@ -173,6 +175,7 @@ (define eof-object? (lambda (x) (sys:eof-object? x))) (define bwp-object? (lambda (x) (sys:bwp-object? x))) + (define transcoder? (lambda (x) (sys:transcoder? x))) (define immediate? (lambda (x) (sys:immediate? x))) (define boolean? (lambda (x) (sys:boolean? x))) (define char? (lambda (x) (sys:char? x))) diff --git a/scheme/ikarus.writer.ss b/scheme/ikarus.writer.ss index 6d7f4f8..0636330 100644 --- a/scheme/ikarus.writer.ss +++ b/scheme/ikarus.writer.ss @@ -589,7 +589,7 @@ [(number? x) (write-char* (number->string x) p) i] - [($transcoder? x) + [(transcoder? x) (write-char* "#data x)]) (write-char* (number->string n) p)) diff --git a/scheme/last-revision b/scheme/last-revision index 03183b0..0b2a2c0 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1187 +1190 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index fe7c196..2b91432 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -1133,6 +1133,7 @@ [make-transcoder i r ip] [native-eol-style i r ip] [native-transcoder i r ip] + [transcoder? i] [open-bytevector-input-port r ip] [open-bytevector-output-port i r ip] [open-file-input-port r ip] @@ -1298,7 +1299,6 @@ [library i] [syntax-dispatch ] [syntax-error i r sc] - [$transcoder? $transc] [$transcoder->data $transc] [$data->transcoder $transc] [file-options-spec i] diff --git a/scheme/pass-specify-rep-primops.ss b/scheme/pass-specify-rep-primops.ss index d0ef288..cd9f336 100644 --- a/scheme/pass-specify-rep-primops.ss +++ b/scheme/pass-specify-rep-primops.ss @@ -1964,8 +1964,10 @@ /section) (section ; transcoders -(define-primop $transcoder? unsafe + +(define-primop transcoder? unsafe [(P x) (tag-test (T x) transcoder-mask transcoder-tag)]) + (define-primop $data->transcoder unsafe [(V x) (prm 'logor (prm 'sll (T x) (K (- transcoder-payload-shift fixnum-shift)))