ikarus/scheme/ikarus.io.ss

1791 lines
62 KiB
Scheme

;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
#;
(library (ikarus system $io tmp)
(export $make-port $port-tag $port-id $port-cookie
port? $port-transcoder
$port-index $port-size $port-buffer
$port-get-position $port-set-position! $port-close
$port-read! $port-write! $set-port-index! $set-port-size!
$port-attrs $set-port-attrs!)
(import (except (ikarus) port?))
(define-struct $port
(attrs index size buffer transcoder
id read! write! get-position set-position! close cookie))
(define port? $port?)
(define $set-port-index! set-$port-index!)
(define $set-port-size! set-$port-size!)
(define $set-port-attrs! set-$port-attrs!)
(define $make-port make-$port)
(define ($port-tag x) (if ($port? x) ($port-attrs x) 0)))
(library (io-spec)
(export
port? input-port? output-port? textual-port? binary-port?
open-file-input-port open-input-file
call-with-input-file with-input-from-file
standard-input-port current-input-port
open-bytevector-input-port
open-string-input-port
make-custom-binary-input-port
make-custom-binary-output-port
make-custom-textual-input-port
make-custom-textual-output-port
transcoded-port port-transcoder
close-port close-input-port close-output-port
port-eof?
get-char lookahead-char read-char peek-char
get-string-n get-string-n! get-string-all get-line
get-u8 lookahead-u8
get-bytevector-n get-bytevector-n!
get-bytevector-some get-bytevector-all
;port-has-port-position? port-position
;port-has-set-port-position!? set-port-position!
call-with-port
flush-output-port
put-u8
put-char write-char
put-string
open-bytevector-output-port
call-with-bytevector-output-port
open-string-output-port
call-with-string-output-port
standard-output-port standard-error-port
current-output-port current-error-port
open-file-output-port open-output-file
console-output-port
console-error-port
console-input-port
newline
input-port-name
output-port-name
port-mode set-port-mode!
reset-input-port!
port-id
)
(import
(ikarus system $io)
(except (ikarus)
port? input-port? output-port? textual-port? binary-port?
open-file-input-port open-input-file
call-with-input-file with-input-from-file
standard-input-port current-input-port
open-bytevector-input-port
open-string-input-port
make-custom-binary-input-port
make-custom-binary-output-port
make-custom-textual-input-port
make-custom-textual-output-port
transcoded-port port-transcoder
close-port close-input-port close-output-port
port-eof?
get-char lookahead-char read-char peek-char
get-string-n get-string-n! get-string-all get-line
get-u8 lookahead-u8
get-bytevector-n get-bytevector-n!
get-bytevector-some get-bytevector-all
;port-has-port-position? port-position
;port-has-set-port-position!? set-port-position!
call-with-port
flush-output-port
put-u8
put-char write-char
put-string
open-bytevector-output-port
call-with-bytevector-output-port
open-string-output-port
call-with-string-output-port
standard-output-port standard-error-port
current-output-port current-error-port
open-file-output-port open-output-file
console-output-port
console-input-port
console-error-port
newline
input-port-name
output-port-name
port-mode set-port-mode!
reset-input-port!
port-id
))
(module UNSAFE
(fx< fx<= fx> fx>= fx= fx+ fx-
fxior fxand fxsra fxsll
integer->char char->integer
string-ref string-set! string-length
bytevector-u8-ref bytevector-u8-set!)
(import
(rename (ikarus system $strings)
($string-length string-length)
($string-ref string-ref)
($string-set! string-set!))
(rename (ikarus system $chars)
($char->fixnum char->integer)
($fixnum->char integer->char))
(rename (ikarus system $bytevectors)
($bytevector-set! bytevector-u8-set!)
($bytevector-u8-ref bytevector-u8-ref))
(rename (ikarus system $fx)
($fxsra fxsra)
($fxsll fxsll)
($fxlogor fxior)
($fxlogand fxand)
($fx+ fx+)
($fx- fx-)
($fx< fx<)
($fx> fx>)
($fx>= fx>=)
($fx<= fx<=)
($fx= fx=))))
(define (port? x)
(import (only (ikarus) port?))
(port? x))
(define-syntax define-rrr
(syntax-rules ()
[(_ name)
(define (name . args)
(apply die 'name "not implemented" args))]))
(define-syntax u8?
(let ()
(import (ikarus system $fx))
(syntax-rules ()
[(_ x)
($fxzero? ($fxlogand x -256))])))
;(define (u8? x) (and (fixnum? x) (fx>= x 0) (fx< x 256)))
(define (textual-port? x)
(fx= (fxand ($port-tag x) textual-port-tag) textual-port-tag))
(define (binary-port? x)
(fx= (fxand ($port-tag x) binary-port-tag) binary-port-tag))
(define (output-port? x)
(fx= (fxand ($port-tag x) output-port-tag) output-port-tag))
(define (input-port? x)
(fx= (fxand ($port-tag x) input-port-tag) input-port-tag))
;;; everything above this line will turn into primitive
;;; ----------------------------------------------------------
(define input-port-tag #b00000000000001)
(define output-port-tag #b00000000000010)
(define textual-port-tag #b00000000000100)
(define binary-port-tag #b00000000001000)
(define fast-char-text-tag #b00000000010000)
(define fast-u7-text-tag #b00000000100000)
(define fast-u8-text-tag #b00000001100000)
(define r6rs-mode-tag #b01000000000000)
(define closed-port-tag #b10000000000000)
(define port-type-mask #b00000000001111)
(define binary-input-port-bits #b00000000001001)
(define binary-output-port-bits #b00000000001010)
(define textual-input-port-bits #b00000000000101)
(define textual-output-port-bits #b00000000000110)
(define fast-get-byte-tag #b00000000001001)
(define fast-get-char-tag #b00000000010101)
(define fast-get-utf8-tag #b00000000100101)
(define fast-get-latin-tag #b00000001100101)
(define fast-put-byte-tag #b00000000001010)
(define fast-put-char-tag #b00000000010110)
(define fast-put-utf8-tag #b00000000100110)
(define fast-put-latin-tag #b00000001100110)
(define fast-attrs-mask #xFFF)
(define ($port-fast-attrs x) (fxand ($port-tag x) fast-attrs-mask))
(define (input-port-name p)
(if (input-port? p)
($port-id p)
(die 'input-port-name "not an input port" p)))
(define (output-port-name p)
(if (output-port? p)
($port-id p)
(die 'output-port-name "not an output port" p)))
(define (port-id p)
(if (port? p)
($port-id p)
(die 'port-id "not a port" p)))
(define guarded-port
(let ([G (make-guardian)])
(define (clean-up)
(cond
[(G) =>
(lambda (p)
(close-port p)
(clean-up))]))
(lambda (p)
(clean-up)
(when (fixnum? ($port-cookie p))
(G p))
p)))
(define ($make-custom-binary-port attrs init-size id
read! write! get-position set-position! close buffer-size)
(let ([bv (make-bytevector buffer-size)])
($make-port attrs 0 init-size bv #f id read! write! get-position
set-position! close #f)))
(define ($make-custom-textual-port attrs init-size id
read! write! get-position set-position! close buffer-size)
(let ([bv (make-string buffer-size)])
($make-port attrs 0 init-size bv #t id read! write! get-position
set-position! close #f)))
(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)
(die who "id is not a string" id))
(unless (procedure? read!)
(die who "read! is not a procedure" read!))
(unless (or (procedure? close) (not close))
(die who "close should be either a procedure or #f" close))
($make-custom-binary-port
binary-input-port-bits
0
id read! #f get-position
set-position! close 256))
(define (make-custom-binary-output-port id
write! get-position set-position! close)
;;; FIXME: get-position and set-position! are ignored for now
(define who 'make-custom-binary-output-port)
(unless (string? id)
(die who "id is not a string" id))
(unless (procedure? write!)
(die who "write! is not a procedure" write!))
(unless (or (procedure? close) (not close))
(die who "close should be either a procedure or #f" close))
($make-custom-binary-port
binary-output-port-bits
256
id #f write! get-position
set-position! close 256))
(define (make-custom-textual-input-port id
read! get-position set-position! close)
;;; FIXME: get-position and set-position! are ignored for now
(define who 'make-custom-textual-input-port)
(unless (string? id)
(die who "id is not a string" id))
(unless (procedure? read!)
(die who "read! is not a procedure" read!))
(unless (or (procedure? close) (not close))
(die who "close should be either a procedure or #f" close))
($make-custom-textual-port
(fxior textual-input-port-bits fast-char-text-tag)
0
id read! #f get-position
set-position! close 256))
(define (make-custom-textual-output-port id
write! get-position set-position! close)
;;; FIXME: get-position and set-position! are ignored for now
(define who 'make-custom-textual-output-port)
(unless (string? id)
(die who "id is not a string" id))
(unless (procedure? write!)
(die who "write! is not a procedure" write!))
(unless (or (procedure? close) (not close))
(die who "close should be either a procedure or #f" close))
($make-custom-textual-port
(fxior textual-output-port-bits fast-char-text-tag)
256
id #f write! get-position
set-position! close 256))
(define (input-transcoder-attrs x)
(cond
[(not x) ;;; binary input port
binary-input-port-bits]
[(and (eq? 'latin-1-codec (transcoder-codec x))
(eq? 'none (transcoder-eol-style x)))
(fxior textual-input-port-bits fast-u8-text-tag)]
;;; attrs for utf-8-codec are set as part of the
;;; bom-reading dance when the first char is read.
[else textual-input-port-bits]))
(define (output-transcoder-attrs x)
(cond
[(not x) ;;; binary input port
binary-output-port-bits]
[(and (eq? 'latin-1-codec (transcoder-codec x))
(eq? 'none (transcoder-eol-style x)))
(fxior textual-output-port-bits fast-u8-text-tag)]
[(and (eq? 'utf-8-codec (transcoder-codec x))
(eq? 'none (transcoder-eol-style x)))
(fxior textual-output-port-bits fast-u7-text-tag)]
[else textual-output-port-bits]))
(define open-bytevector-input-port
(case-lambda
[(bv) (open-bytevector-input-port bv #f)]
[(bv maybe-transcoder)
(unless (bytevector? bv)
(die 'open-bytevector-input-port
"not a bytevector" bv))
(when (and maybe-transcoder
(not (transcoder? maybe-transcoder)))
(die 'open-bytevector-input-port
"not a transcoder" maybe-transcoder))
($make-port
(input-transcoder-attrs maybe-transcoder)
0 (bytevector-length bv) bv
maybe-transcoder
"*bytevector-input-port*"
(lambda (bv i c) 0) ;;; read!
#f ;;; write!
#f ;;; FIXME: get-position
#f ;;; FIXME: set-position!
#f ;;; close
#f)]))
(define open-bytevector-output-port
(case-lambda
[() (open-bytevector-output-port #f)]
[(transcoder)
(define who 'open-bytevector-output-port)
(unless (or (not transcoder) (transcoder? transcoder))
(die who "invalid transcoder value" transcoder))
(let ([buf* '()] [buffer-size 256])
(let ([p
($make-port
(output-transcoder-attrs transcoder)
0 buffer-size (make-bytevector buffer-size)
transcoder
"*bytevector-output-port*"
#f
(lambda (bv i c)
(unless (= c 0)
(let ([x (make-bytevector c)])
(bytevector-copy! bv i x 0 c)
(set! buf* (cons x buf*))))
c)
#f ;;; FIXME: get-position
#f ;;; FIXME: set-position!
#f
#f)])
(values
p
(lambda ()
(define (append-bv-buf* ls)
(let f ([ls ls] [i 0])
(cond
[(null? ls)
(values (make-bytevector i) 0)]
[else
(let* ([a (car ls)]
[n (bytevector-length a)])
(let-values ([(bv i) (f (cdr ls) (fx+ i n))])
(bytevector-copy! a 0 bv i n)
(values bv (fx+ i n))))])))
(unless ($port-closed? p)
(flush-output-port p))
(let-values ([(bv len) (append-bv-buf* buf*)])
(set! buf* '())
bv)))))]))
(define call-with-bytevector-output-port
(case-lambda
[(proc) (call-with-bytevector-output-port proc #f)]
[(proc transcoder)
(define who 'call-with-bytevector-output-port)
(unless (procedure? proc)
(die who "not a procedure" proc))
(unless (or (not transcoder) (transcoder? transcoder))
(die who "invalid transcoder argument" transcoder))
(let-values ([(p extract)
(open-bytevector-output-port transcoder)])
(proc p)
(extract))]))
(define (call-with-string-output-port proc)
(define who 'call-with-string-output-port)
(unless (procedure? proc)
(die who "not a procedure" proc))
(let-values ([(p extract) (open-string-output-port)])
(proc p)
(extract)))
(define (open-string-output-port)
(define who 'open-string-output-port)
(let ([buf* '()] [buffer-size 256])
(let ([p
($make-port
(fxior textual-output-port-bits fast-char-text-tag)
0 buffer-size (make-string buffer-size)
#t ;;; transcoder
"*string-output-port*"
#f
(lambda (str i c)
(unless (= c 0)
(let ([x (make-string c)])
(string-copy! str i x 0 c)
(set! buf* (cons x buf*))))
c)
#f ;;; FIXME: get-position
#f ;;; FIXME: set-position!
#f
#f)])
(values
p
(lambda ()
(define (append-str-buf* ls)
(let f ([ls ls] [i 0])
(cond
[(null? ls)
(values (make-string i) 0)]
[else
(let* ([a (car ls)]
[n (string-length a)])
(let-values ([(bv i) (f (cdr ls) (fx+ i n))])
(string-copy! a 0 bv i n)
(values bv (fx+ i n))))])))
(unless ($port-closed? p)
(flush-output-port p))
(let-values ([(bv len) (append-str-buf* buf*)])
(set! buf* '())
bv))))))
(define (open-string-input-port str)
(unless (string? str)
(die 'open-string-input-port str))
($make-port
(fxior textual-input-port-bits fast-char-text-tag)
0 (string-length str) str
#t ;;; transcoder
"*string-input-port*"
(lambda (str i c) 0) ;;; read!
#f ;;; write!
#f ;;; FIXME: get-position
#f ;;; FIXME: set-position!
#f ;;; close
#f))
(define (transcoded-port p transcoder)
(define who 'transcoded-port)
(unless (transcoder? transcoder)
(die who "not a transcoder" transcoder))
(unless (port? p) (die who "not a port" p))
(when ($port-transcoder p) (die who "not a binary port" p))
(when ($port-closed? p) (die who "cannot transcode closed port" p))
(let ([read! ($port-read! p)]
[write! ($port-write! p)])
($mark-port-closed! p)
(guarded-port
($make-port
(cond
[read! (input-transcoder-attrs transcoder)]
[write! (output-transcoder-attrs transcoder)]
[else
(die 'transcoded-port
"port is neither input nor output!")])
($port-index p)
($port-size p)
($port-buffer p)
transcoder
($port-id p)
read!
write!
($port-get-position p)
($port-set-position! p)
($port-close p)
($port-cookie p)))))
(define (reset-input-port! p)
(if (input-port? p)
($set-port-index! p ($port-size p))
(die 'reset-input-port! "not an input port" p)))
(define (port-transcoder p)
(if (port? p)
(let ([tr ($port-transcoder p)])
(and (transcoder? tr) tr))
(die 'port-transcoder "not a port" p)))
(define ($port-closed? p)
(not (fxzero? (fxand ($port-attrs p) closed-port-tag))))
(define ($mark-port-closed! p)
($set-port-attrs! p
(fxior closed-port-tag
(fxand ($port-attrs p) port-type-mask))))
(define (port-mode p)
(if (port? p)
(if (fxzero? (fxand ($port-attrs p) r6rs-mode-tag))
'ikarus-mode
'r6rs-mode)
(die 'port-mode "not a port" p)))
(define (set-port-mode! p mode)
(if (port? p)
(case mode
[(r6rs-mode)
($set-port-attrs! p
(fxior ($port-attrs p) r6rs-mode-tag))]
[(ikarus-mode)
($set-port-attrs! p
(fxand ($port-attrs p) (fxnot r6rs-mode-tag)))]
[else (die 'set-port-mode! "invalid mode" mode)])
(die 'set-port-mode! "not a port" p)))
(define flush-output-port
(case-lambda
[() (flush-output-port (*the-output-port*))]
[(p)
(unless (output-port? p)
(die 'flush-output-port "not an output port" p))
(when ($port-closed? p)
(die 'flush-output-port "port is closed" p))
(let ([idx ($port-index p)]
[buf ($port-buffer p)])
(unless (fx= idx 0)
(let ([bytes (($port-write! p) buf 0 idx)])
(unless (and (fixnum? bytes) (fx>= bytes 0) (fx<= bytes idx))
(die 'flush-output-port
"write! returned an invalid value"
bytes))
(cond
[(fx= bytes idx)
($set-port-index! p 0)]
[(fx= bytes 0)
(die 'flush-output-port "could not write bytes to sink")]
[else
(bytevector-copy! buf bytes buf 0 (fx- idx bytes))
($set-port-index! p (fx- idx bytes))
(flush-output-port p)]))))]))
(define ($close-port p)
(cond
[($port-closed? p) (void)]
[else
(when ($port-write! p)
(flush-output-port p))
($mark-port-closed! p)
(let ([close ($port-close p)])
(when (procedure? close)
(close)))]))
(define (close-port p)
(unless (port? p)
(die 'close-port "not a port" p))
($close-port p))
(define (close-input-port p)
(unless (input-port? p)
(die 'close-input-port "not an input port" p))
($close-port p))
(define (close-output-port p)
(unless (output-port? p)
(die 'close-output-port "not an output port" p))
($close-port p))
;(define-rrr port-has-port-position?)
;(define-rrr port-position)
;(define-rrr port-has-set-port-position!?)
;(define-rrr set-port-position!)
;;; ----------------------------------------------------------
(module (get-char lookahead-char)
(import UNSAFE)
(define (refill-bv-start p who)
(when ($port-closed? p) (die 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)
(die who "invalid return value from read! procedure" j))
(cond
[(fx>= j 0)
(unless (fx<= j n)
(die who "read! returned a value out of range" j))
($set-port-index! p 0)
($set-port-size! p j)
j]
[else
(die who "read! returned a value out of range" j)]))))
(define (refill-bv-buffer p who)
(when ($port-closed? p) (die who "port is closed" p))
(let ([bv ($port-buffer p)] [i ($port-index p)] [j ($port-size p)])
(let ([c0 (fx- j i)])
(bytevector-copy! bv i bv 0 c0)
(let* ([max (fx- (bytevector-length bv) c0)]
[c1 (($port-read! p) bv c0 max)])
(unless (fixnum? c1)
(die who "invalid return value from read! procedure" c1))
(cond
[(fx>= j 0)
(unless (fx<= j max)
(die who "read! returned a value out of range" j))
($set-port-index! p c0)
($set-port-size! p (fx+ c1 c0))
c1]
[else
(die who "read! returned a value out of range" c1)])))))
(define (get-char-latin-mode p who idx)
(let ([n (refill-bv-start p who)])
(cond
[(fx= n 0) (eof-object)]
[else
($set-port-index! p idx)
(integer->char (bytevector-u8-ref ($port-buffer p) 0))])))
(define (get-char-utf8-mode p who)
(define (do-error p who)
(case (transcoder-error-handling-mode ($port-transcoder p))
[(ignore) (get-char p)]
[(replace) #\xFFFD]
[(raise)
(raise (make-i/o-decoding-error p))]
[else (die who "cannot happen")]))
(let ([i ($port-index p)]
[j ($port-size p)]
[buf ($port-buffer p)])
(cond
[(fx= i j) ;;; exhausted
(let ([bytes (refill-bv-buffer p who)])
(cond
[(fx= bytes 0) (eof-object)]
[else (get-char p)]))]
[else
(let ([b0 (bytevector-u8-ref buf i)])
(cond
[(fx= (fxsra b0 5) #b110) ;;; two-byte-encoding
(let ([i (fx+ i 1)])
(cond
[(fx< i j)
(let ([b1 (bytevector-u8-ref buf i)])
(cond
[(fx= (fxsra b1 6) #b10)
($set-port-index! p (fx+ i 1))
(integer->char
(fxior (fxand b1 #b111111)
(fxsll (fxand b0 #b11111) 6)))]
[else
($set-port-index! p i)
(do-error p who)]))]
[else
(let ([bytes (refill-bv-buffer p who)])
(cond
[(fx= bytes 0)
($set-port-index! p (fx+ ($port-index p) 1))
(do-error p who)]
[else (get-char-utf8-mode p who)]))]))]
[(fx= (fxsra b0 4) #b1110) ;;; three-byte-encoding
(cond
[(fx< (fx+ i 2) j)
(let ([b1 (bytevector-u8-ref buf (fx+ i 1))]
[b2 (bytevector-u8-ref buf (fx+ i 2))])
(cond
[(fx= (fxsra (fxlogor b1 b2) 6) #b10)
(let ([n (fxlogor
(fxsll (fxand b0 #b1111) 12)
(fxsll (fxand b1 #b111111) 6)
(fxand b2 #b111111))])
(cond
[(and (fx<= #xD800 n) (fx<= n #xDFFF))
($set-port-index! p (fx+ i 1))
(do-error p who)]
[else
($set-port-index! p (fx+ i 3))
(integer->char n)]))]
[else
($set-port-index! p (fx+ i 1))
(do-error p who)]))]
[else
(let ([bytes (refill-bv-buffer p who)])
(cond
[(fx= bytes 0)
($set-port-index! p (fx+ ($port-index p) 1))
(do-error p who)]
[else (get-char-utf8-mode p who)]))])]
[(fx= (fxsra b0 3) #b11110) ;;; four-byte-encoding
(cond
[(fx< (fx+ i 3) j)
(let ([b1 (bytevector-u8-ref buf (fx+ i 1))]
[b2 (bytevector-u8-ref buf (fx+ i 2))]
[b3 (bytevector-u8-ref buf (fx+ i 3))])
(cond
[(fx= (fxsra (fxlogor b1 b2 b3) 6) #b10)
(let ([n (fxlogor
(fxsll (fxand b0 #b111) 18)
(fxsll (fxand b1 #b111111) 12)
(fxsll (fxand b2 #b111111) 6)
(fxand b3 #b111111))])
(cond
[(and (fx<= #x10000 n) (fx<= n #x10FFFF))
($set-port-index! p (fx+ i 4))
(integer->char n)]
[else
($set-port-index! p (fx+ i 1))
(do-error p who)]))]
[else
($set-port-index! p (fx+ i 1))
(do-error p who)]))]
[else
(let ([bytes (refill-bv-buffer p who)])
(cond
[(fx= bytes 0)
($set-port-index! p (fx+ ($port-index p) 1))
(do-error p who)]
[else (get-char-utf8-mode p who)]))])]
[else
($set-port-index! p (fx+ i 1))
(do-error p who)]))])))
(define (lookahead-char-utf8-mode p who)
(define (do-error p who)
(case (transcoder-error-handling-mode ($port-transcoder p))
[(ignore) (get-char p)]
[(replace) #\xFFFD]
[(raise)
(raise (make-i/o-decoding-error p))]
[else (die who "cannot happen")]))
(let ([i ($port-index p)]
[j ($port-size p)]
[buf ($port-buffer p)])
(cond
[(fx= i j) ;;; exhausted
(let ([bytes (refill-bv-buffer p who)])
(cond
[(fx= bytes 0) (eof-object)]
[else (lookahead-char p)]))]
[else
(let ([b0 (bytevector-u8-ref buf i)])
(cond
[(fx= (fxsra b0 5) #b110) ;;; two-byte-encoding
(let ([i (fx+ i 1)])
(cond
[(fx< i j)
(let ([b1 (bytevector-u8-ref buf i)])
(cond
[(fx= (fxsra b1 6) #b10)
(integer->char
(fxior (fxand b1 #b111111)
(fxsll (fxand b0 #b11111) 6)))]
[else
(do-error p who)]))]
[else
(let ([bytes (refill-bv-buffer p who)])
(cond
[(fx= bytes 0) (do-error p who)]
[else (lookahead-char-utf8-mode p who)]))]))]
[(fx= (fxsra b0 4) #b1110) ;;; three-byte-encoding
(cond
[(fx< (fx+ i 2) j)
(let ([b1 (bytevector-u8-ref buf (fx+ i 1))]
[b2 (bytevector-u8-ref buf (fx+ i 2))])
(cond
[(fx= (fxsra (fxlogor b1 b2) 6) #b10)
(let ([n (fxlogor
(fxsll (fxand b0 #b1111) 12)
(fxsll (fxand b1 #b111111) 6)
(fxand b2 #b111111))])
(cond
[(and (fx<= #xD800 n) (fx<= n #xDFFF))
(do-error p who)]
[else (integer->char n)]))]
[else (do-error p who)]))]
[else
(let ([bytes (refill-bv-buffer p who)])
(cond
[(fx= bytes 0) (do-error p who)]
[else (lookahead-char-utf8-mode p who)]))])]
[(fx= (fxsra b0 3) #b11110) ;;; four-byte-encoding
(cond
[(fx< (fx+ i 3) j)
(let ([b1 (bytevector-u8-ref buf (fx+ i 1))]
[b2 (bytevector-u8-ref buf (fx+ i 2))]
[b3 (bytevector-u8-ref buf (fx+ i 3))])
(cond
[(fx= (fxsra (fxlogor b1 b2 b3) 6) #b10)
(let ([n (fxlogor
(fxsll (fxand b0 #b111) 18)
(fxsll (fxand b1 #b111111) 12)
(fxsll (fxand b2 #b111111) 6)
(fxand b3 #b111111))])
(cond
[(and (fx<= #x10000 n) (fx<= n #x10FFFF))
(integer->char n)]
[else
(do-error p who)]))]
[else
(do-error p who)]))]
[else
(let ([bytes (refill-bv-buffer p who)])
(cond
[(fx= bytes 0)
(do-error p who)]
[else (lookahead-char-utf8-mode p who)]))])]
[else (do-error p who)]))])))
(define (advance-bom p who bom-seq)
;;; return eof if port is eof,
;;; #t if a bom is present, updating the port index to
;;; point just past the bom.
;;; #f otherwise.
(cond
[(fx< ($port-index p) ($port-size p))
(let f ([i 0] [ls bom-seq])
(cond
[(null? ls)
($set-port-index! p (fx+ ($port-index p) i))
#t]
[else
(let ([idx (fx+ i ($port-index p))])
(cond
[(fx< idx ($port-size p))
(if (fx=? (car ls)
(bytevector-u8-ref ($port-buffer p) idx))
(f (fx+ i 1) (cdr ls))
#f)]
[else
(let ([bytes (refill-bv-buffer p who)])
(if (fx= bytes 0)
#f
(f i ls)))]))]))]
[else
(let ([bytes (refill-bv-buffer p who)])
(if (fx= bytes 0)
(eof-object)
(advance-bom p who bom-seq)))]))
(define (speedup-input-port p who)
;;; returns #t if port is eof, #f otherwise
(unless (input-port? p)
(die who "not an input port" p))
(let ([tr ($port-transcoder p)])
(unless tr
(die who "not a textual port" p))
(case (transcoder-codec tr)
[(utf-8-codec)
;;;
($set-port-attrs! p
(fxior textual-input-port-bits fast-u7-text-tag))
(eof-object? (advance-bom p who '(#xEF #xBB #xBF)))]
[else (die 'slow-get-char "codec not handled")])))
(define (lookahead-char-char-mode p who)
(let ([str ($port-buffer p)]
[read! ($port-read! p)])
(let ([n (read! str 0 (string-length str))])
(unless (fixnum? n)
(die who "invalid return value from read!" n))
(unless (<= 0 n (string-length str))
(die who "return value from read! is out of range" n))
($set-port-index! p 0)
($set-port-size! p n)
(cond
[(fx= n 0)
(eof-object)]
[else
(string-ref str 0)]))))
;;;
(define (lookahead-char p)
(define who 'lookahead-char)
(let ([m ($port-fast-attrs p)])
(cond
[(eq? m fast-get-utf8-tag)
(let ([i ($port-index p)])
(cond
[(fx< i ($port-size p))
(let ([b (bytevector-u8-ref ($port-buffer p) i)])
(cond
[(fx< b 128) (integer->char b)]
[else (lookahead-char-utf8-mode p who)]))]
[else
(lookahead-char-utf8-mode p who)]))]
[(eq? m fast-get-char-tag)
(let ([i ($port-index p)])
(cond
[(fx< i ($port-size p))
(string-ref ($port-buffer p) i)]
[else
(lookahead-char-char-mode p who)]))]
[(eq? m fast-get-latin-tag)
(let ([i ($port-index p)])
(cond
[(fx< i ($port-size p))
(integer->char
(bytevector-u8-ref ($port-buffer p) i))]
[else
(get-char-latin-mode p who 0)]))]
[else
(if (speedup-input-port p who)
(eof-object)
(lookahead-char p))])))
;;;
(define (get-char-char-mode p who)
(let ([str ($port-buffer p)]
[read! ($port-read! p)])
(let ([n (read! str 0 (string-length str))])
(unless (fixnum? n)
(die who "invalid return value from read!" n))
(unless (<= 0 n (string-length str))
(die who "return value from read! is out of range" n))
($set-port-size! p n)
(cond
[(fx= n 0)
($set-port-index! p 0)
(eof-object)]
[else
($set-port-index! p 1)
(string-ref str 0)]))))
(define (get-char p)
(define who 'get-char)
(let ([m ($port-fast-attrs p)])
(cond
[(eq? m fast-get-utf8-tag)
(let ([i ($port-index p)])
(cond
[(fx< i ($port-size p))
(let ([b (bytevector-u8-ref ($port-buffer p) i)])
(cond
[(fx< b 128)
($set-port-index! p (fx+ i 1))
(integer->char b)]
[else (get-char-utf8-mode p who)]))]
[else
(get-char-utf8-mode p who)]))]
[(eq? m fast-get-char-tag)
(let ([i ($port-index p)])
(cond
[(fx< i ($port-size p))
($set-port-index! p (fx+ i 1))
(string-ref ($port-buffer p) i)]
[else (get-char-char-mode p who)]))]
[(eq? m fast-get-latin-tag)
(let ([i ($port-index p)])
(cond
[(fx< i ($port-size p))
($set-port-index! p (fx+ i 1))
(integer->char
(bytevector-u8-ref ($port-buffer p) i))]
[else
(get-char-latin-mode p who 1)]))]
[else
(if (speedup-input-port p who)
(eof-object)
(get-char p))]))))
;;; ----------------------------------------------------------
(define (assert-binary-input-port p who)
(unless (port? p) (die who "not a port" p))
(when ($port-closed? p) (die who "port is closed" p))
(when ($port-transcoder p) (die who "port is not binary" p))
(unless ($port-read! p)
(die who "port is not an input port" p)))
(module (get-u8 lookahead-u8)
(import UNSAFE)
(define (get-u8-byte-mode p who start)
(when ($port-closed? p) (die 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)
(die who "invalid return value from read! procedure" j))
(cond
[(fx> j 0)
(unless (fx<= j n)
(die 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
(die 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 fast-get-byte-tag)
(get-u8-byte-mode p who start))
;;;
(define (get-u8 p)
(define who 'get-u8)
(let ([m ($port-fast-attrs p)])
(cond
[(eq? m fast-get-byte-tag)
(let ([i ($port-index p)])
(cond
[(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 1)]))]
[else (slow-get-u8 p who 1)])))
(define (lookahead-u8 p)
(define who 'lookahead-u8)
(let ([m ($port-fast-attrs 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)
(import UNSAFE)
(define who 'port-eof?)
(let ([m ($port-fast-attrs p)])
(cond
[(not (eq? m 0))
(if (fx< ($port-index p) ($port-size p))
#f
(if ($port-transcoder p)
(eof-object? (lookahead-char p))
(eof-object? (lookahead-u8 p))))]
[(input-port? p)
(when ($port-closed? p)
(die 'port-eof? "port is closed" p))
(if (textual-port? p)
(eof-object? (lookahead-char p))
(eof-object? (lookahead-u8 p)))]
[else (die 'port-eof? "not an input port" p)])))
(define io-errors-vec
'#("unknown die"
"bad file name"
"operation interrupted"
"not a directory"
"file name too long"
"missing entities"
"insufficient access privileges"
"circular path"
"file is a directory"
"file system is read-only"
"maximum open files reached"
"maximum open files reached"
"ENXIO"
"operation not supported"
"not enough space on device"
"quota exceeded"
"io die"
"device is busy"
"access fault"
"file already exists"
"invalid file name"))
(define (io-error who id err)
(let ([msg
(let ([err (fxnot err)])
(cond
[(fx< err (vector-length io-errors-vec))
(vector-ref io-errors-vec err)]
[else "unknown die"]))])
(raise
(condition
(make-error)
(make-who-condition who)
(make-message-condition msg)
(make-i/o-filename-error id)))))
(define block-size 4096)
(define input-file-buffer-size (+ block-size 128))
(define output-file-buffer-size block-size)
(define (fh->input-port fd id size transcoder close?)
(guarded-port
($make-port
(input-transcoder-attrs transcoder)
0 0 (make-bytevector size)
transcoder
id
(lambda (bv idx cnt)
(let ([bytes
(foreign-call "ikrt_read_fd" fd bv idx
(fxmin block-size cnt))])
(when (fx< bytes 0) (io-error 'read id bytes))
bytes))
#f ;;; write!
#f ;;; get-position
#f ;;; set-position!
(and close?
(lambda ()
(cond
[(foreign-call "ikrt_close_fd" fd) =>
(lambda (err)
(io-error 'close id err))])))
fd)))
(define (fh->output-port fd id size transcoder close?)
(guarded-port
($make-port
(output-transcoder-attrs transcoder)
0 size (make-bytevector size)
transcoder
id
#f
(lambda (bv idx cnt)
(let ([bytes
(foreign-call "ikrt_write_fd" fd bv idx
(fxmin block-size cnt))])
(when (fx< bytes 0) (io-error 'write id bytes))
bytes))
#f ;;; get-position
#f ;;; set-position!
(and close?
(lambda ()
(cond
[(foreign-call "ikrt_close_fd" fd) =>
(lambda (err)
(io-error 'close id err))])))
fd)))
(define (open-input-file-handle filename who)
(let ([fh (foreign-call "ikrt_open_input_fd"
(string->utf8 filename))])
(cond
[(fx< fh 0) (io-error who filename fh)]
[else fh])))
(define (open-output-file-handle filename file-options who)
(let ([opt (case file-options
[(fo:default) 0]
[(fo:no-create) 1]
[(fo:no-fail) 2]
[(fo:no-fail/no-create) 3]
[(fo:no-truncate) 4]
[(fo:no-truncate/no-create) 5]
[(fo:no-truncate/no-fail) 6]
[(fo:no-truncate/no-fail/no-create) 7]
[else (die who "invalid file option" file-options)])])
(let ([fh (foreign-call "ikrt_open_output_fd"
(string->utf8 filename)
opt)])
(cond
[(fx< fh 0) (io-error who filename fh)]
[else fh]))))
(define open-file-input-port
(case-lambda
[(filename)
(open-file-input-port filename (file-options) 'block #f)]
[(filename file-options)
(open-file-input-port filename file-options 'block #f)]
[(filename file-options buffer-mode)
(open-file-input-port filename file-options buffer-mode #f)]
[(filename file-options buffer-mode transcoder)
(unless (string? filename)
(die 'open-file-input-port "invalid filename" filename))
(unless (or (not transcoder) (transcoder? transcoder))
(die 'open-file-input-port "invalid transcoder" transcoder))
; FIXME: file-options ignored
; FIXME: buffer-mode ignored
(fh->input-port
(open-input-file-handle filename 'open-file-input-port)
filename
input-file-buffer-size
transcoder
#t)]))
(define open-file-output-port
(case-lambda
[(filename)
(open-file-output-port filename (file-options) 'block #f)]
[(filename file-options)
(open-file-output-port filename file-options 'block #f)]
[(filename file-options buffer-mode)
(open-file-output-port filename file-options buffer-mode #f)]
[(filename file-options buffer-mode transcoder)
(unless (string? filename)
(die 'open-file-output-port "invalid filename" filename))
; FIXME: file-options ignored
; FIXME: buffer-mode ignored
(unless (or (not transcoder) (transcoder? transcoder))
(die 'open-file-output-port "invalid transcoder" transcoder))
(fh->output-port
(open-output-file-handle filename file-options
'open-file-output-port)
filename
output-file-buffer-size
transcoder
#t)]))
(define (open-output-file filename)
(unless (string? filename)
(die 'open-output-file "invalid filename" filename))
(fh->output-port
(open-output-file-handle filename (file-options)
'open-input-file)
filename
output-file-buffer-size
(native-transcoder)
#t))
(define (open-input-file filename)
(unless (string? filename)
(die 'open-input-file "invalid filename" filename))
(fh->input-port
(open-input-file-handle filename 'open-input-file)
filename
input-file-buffer-size
(native-transcoder)
#t))
(define (call-with-input-file filename proc)
(unless (string? filename)
(die 'call-with-input-file "invalid filename" filename))
(unless (procedure? proc)
(die 'call-with-input-file "not a procedure" proc))
(call-with-port
(fh->input-port
(open-input-file-handle filename 'call-with-input-file)
filename
input-file-buffer-size
(native-transcoder)
#t)
proc))
(define (with-input-from-file filename proc)
(unless (string? filename)
(die 'with-input-from-file "invalid filename" filename))
(unless (procedure? proc)
(die 'with-input-from-file "not a procedure" proc))
(let ([p
(fh->input-port
(open-input-file-handle filename 'with-input-from-file)
filename
input-file-buffer-size
(native-transcoder)
#t)])
(parameterize ([*the-input-port* p])
(proc))))
(define (standard-input-port)
(fh->input-port 0 '*stdin* 256 #f #f))
(define (standard-output-port)
(fh->output-port 1 '*stdout* 256 #f #f))
(define (standard-error-port)
(fh->output-port 2 '*stderr* 256 #f #f))
(define *the-input-port*
(make-parameter
(transcoded-port
(fh->input-port 0 '*stdin* input-file-buffer-size #f #f)
(native-transcoder))))
(define *the-output-port*
(make-parameter
(transcoded-port
(fh->output-port 1 '*stdout* output-file-buffer-size #f #f)
(native-transcoder))))
(define *the-error-port*
(make-parameter
(transcoded-port
(fh->output-port 2 '*stderr* output-file-buffer-size #f #f)
(native-transcoder))))
(define console-output-port
(let ([p (*the-output-port*)])
(lambda () p)))
(define console-error-port
(let ([p (*the-error-port*)])
(lambda () p)))
(define console-input-port
(let ([p (*the-input-port*)])
(lambda () p)))
(define (current-input-port) (*the-input-port*))
(define (current-output-port) (*the-output-port*))
(define (current-error-port) (*the-error-port*))
(define (call-with-port p proc)
(if (port? p)
(if (procedure? proc)
(dynamic-wind
void
(lambda () (proc p))
(lambda () (close-port p)))
(die 'call-with-port "not a procedure" proc))
(die 'call-with-port "not a port" p)))
(define read-char
(case-lambda
[() (get-char (*the-input-port*))]
[(p)
(if (input-port? p)
(if (textual-port? p)
(get-char p)
(die 'read-char "not a textual port" p))
(die 'read-char "not an input-port" p))]))
;;;
(define peek-char
(case-lambda
[() (lookahead-char (*the-input-port*))]
[(p)
(if (input-port? p)
(if (textual-port? p)
(lookahead-char p)
(die 'peek-char "not a textual port" p))
(die 'peek-char "not an input-port" p))]))
(define (get-bytevector-n p n)
(import (ikarus system $fx) (ikarus system $bytevectors))
(define (subbytevector s n)
(let ([p ($make-bytevector n)])
(let f ([s s] [n n] [p p])
(let ([n ($fx- n 1)])
($bytevector-set! p n ($bytevector-u8-ref s n))
(if ($fx= n 0)
p
(f s n p))))))
(unless (input-port? p)
(die 'get-bytevector-n "not an input port" p))
(unless (binary-port? p)
(die 'get-bytevector-n "not a binary port" p))
(unless (fixnum? n)
(die 'get-bytevector-n "count is not a fixnum" n))
(cond
[($fx> n 0)
(let ([s ($make-bytevector n)])
(let f ([p p] [n n] [s s] [i 0])
(let ([x (get-u8 p)])
(cond
[(eof-object? x)
(if ($fx= i 0)
(eof-object)
(subbytevector s i))]
[else
($bytevector-set! s i x)
(let ([i ($fxadd1 i)])
(if ($fx= i n)
s
(f p n s i)))]))))]
[($fx= n 0) '#vu8()]
[else (die 'get-bytevector-n "count is negative" n)]))
(define (get-bytevector-n! p s i c)
(import (ikarus system $fx) (ikarus system $bytevectors))
(unless (input-port? p)
(die 'get-bytevector-n! "not an input port" p))
(unless (binary-port? p)
(die 'get-bytevector-n! "not a binary port" p))
(unless (bytevector? s)
(die 'get-bytevector-n! "not a bytevector" s))
(let ([len ($bytevector-length s)])
(unless (fixnum? i)
(die 'get-bytevector-n! "starting index is not a fixnum" i))
(when (or ($fx< i 0) ($fx> i len))
(die 'get-bytevector-n!
(format "starting index is out of range 0..~a" len)
i))
(unless (fixnum? c)
(die 'get-bytevector-n! "count is not a fixnum" c))
(cond
[($fx> c 0)
(let ([j (+ i c)])
(when (> j len)
(die 'get-bytevector-n!
(format "count is out of range 0..~a" (- len i))
c))
(let ([x (get-u8 p)])
(cond
[(eof-object? x) x]
[else
($bytevector-set! s i x)
(let f ([p p] [s s] [start i] [i 1] [c c])
(let ([x (get-u8 p)])
(cond
[(eof-object? x) i]
[else
($bytevector-set! s ($fx+ start i) x)
(let ([i ($fxadd1 i)])
(if ($fx= i c)
i
(f p s start i c)))])))])))]
[($fx= c 0) 0]
[else (die 'get-bytevector-n! "count is negative" c)])))
(define-rrr get-bytevector-some)
(define (get-bytevector-all p)
(define (get-it p)
(let f ([p p] [n 0] [ac '()])
(let ([x (get-u8 p)])
(cond
[(eof-object? x)
(if (null? ac)
(eof-object)
(make-it n ac))]
[else (f p (+ n 1) (cons x ac))]))))
(define (make-it n revls)
(let f ([s (make-bytevector n)] [i (- n 1)] [ls revls])
(cond
[(pair? ls)
(bytevector-u8-set! s i (car ls))
(f s (- i 1) (cdr ls))]
[else s])))
(if (input-port? p)
(if (binary-port? p)
(get-it p)
(die 'get-bytevector-all "not a binary port" p))
(die 'get-bytevector-all "not an input port" p)))
(define (get-string-n p n)
(import (ikarus system $fx) (ikarus system $strings))
(unless (input-port? p)
(die 'get-string-n "not an input port" p))
(unless (textual-port? p)
(die 'get-string-n "not a textual port" p))
(unless (fixnum? n)
(die 'get-string-n "count is not a fixnum" n))
(cond
[($fx> n 0)
(let ([s ($make-string n)])
(let f ([p p] [n n] [s s] [i 0])
(let ([x (get-char p)])
(cond
[(eof-object? x)
(if ($fx= i 0)
(eof-object)
(substring s 0 i))]
[else
($string-set! s i x)
(let ([i ($fxadd1 i)])
(if ($fx= i n)
s
(f p n s i)))]))))]
[($fx= n 0) ""]
[else (die 'get-string-n "count is negative" n)]))
(define (get-string-n! p s i c)
(import (ikarus system $fx) (ikarus system $strings))
(unless (input-port? p)
(die 'get-string-n! "not an input port" p))
(unless (textual-port? p)
(die 'get-string-n! "not a textual port" p))
(unless (string? s)
(die 'get-string-n! "not a string" s))
(let ([len ($string-length s)])
(unless (fixnum? i)
(die 'get-string-n! "starting index is not a fixnum" i))
(when (or ($fx< i 0) ($fx> i len))
(die 'get-string-n!
(format "starting index is out of range 0..~a" len)
i))
(unless (fixnum? c)
(die 'get-string-n! "count is not a fixnum" c))
(cond
[($fx> c 0)
(let ([j (+ i c)])
(when (> j len)
(die 'get-string-n!
(format "count is out of range 0..~a" (- len i))
c))
(let ([x (get-char p)])
(cond
[(eof-object? x) x]
[else
($string-set! s i x)
(let f ([p p] [s s] [start i] [i 1] [c c])
(let ([x (get-char p)])
(cond
[(eof-object? x) i]
[else
($string-set! s ($fx+ start i) x)
(let ([i ($fxadd1 i)])
(if ($fx= i c)
i
(f p s start i c)))])))])))]
[($fx= c 0) 0]
[else (die 'get-string-n! "count is negative" c)])))
(define (get-line p)
(import UNSAFE)
(define (get-it p)
(let f ([p p] [n 0] [ac '()])
(let ([x (get-char p)])
(cond
[(eqv? x #\newline)
(make-it n ac)]
[(eof-object? x)
(if (null? ac) x (make-it n ac))]
[else (f p (fx+ n 1) (cons x ac))]))))
(define (make-it n revls)
(let f ([s (make-string n)] [i (fx- n 1)] [ls revls])
(cond
[(pair? ls)
(string-set! s i (car ls))
(f s (fx- i 1) (cdr ls))]
[else s])))
(if (input-port? p)
(if (textual-port? p)
(get-it p)
(die 'get-line "not a textual port" p))
(die 'get-line "not an input port" p)))
(define (get-string-all p)
(define (get-it p)
(let f ([p p] [n 0] [ac '()])
(let ([x (get-char p)])
(cond
[(eof-object? x)
(if (null? ac)
(eof-object)
(make-it n ac))]
[else (f p (+ n 1) (cons x ac))]))))
(define (make-it n revls)
(let f ([s (make-string n)] [i (- n 1)] [ls revls])
(cond
[(pair? ls)
(string-set! s i (car ls))
(f s (- i 1) (cdr ls))]
[else s])))
(if (input-port? p)
(if (textual-port? p)
(get-it p)
(die 'get-string-all "not a textual port" p))
(die 'get-string-all "not an input port" p)))
;;; ----------------------------------------------------------
(module (put-char write-char put-string)
(import UNSAFE)
(define (put-char-utf8-mode p b who)
(cond
[(fx< b 128)
(flush-output-port p)
(let ([i ($port-index p)] [j ($port-size p)])
(cond
[(fx< i j)
(bytevector-u8-set! ($port-buffer p) i b)
($set-port-index! p (fx+ i 1))]
[else
(die who "insufficient space on port" p)]))]
[(fx<= b #x7FF)
(let ([i ($port-index p)]
[j ($port-size p)]
[buf ($port-buffer p)])
(cond
[(fx< (fx+ i 1) j)
(bytevector-u8-set! buf i
(fxior #b11000000 (fxsra b 6)))
(bytevector-u8-set! buf (fx+ i 1)
(fxior #b10000000 (fxand b #b111111)))
($set-port-index! p (fx+ i 2))]
[else
(flush-output-port p)
(put-char-utf8-mode p b who)]))]
[(fx<= b #xFFFF)
(let ([i ($port-index p)]
[j ($port-size p)]
[buf ($port-buffer p)])
(cond
[(fx< (fx+ i 2) j)
(bytevector-u8-set! buf i
(fxior #b11100000 (fxsra b 12)))
(bytevector-u8-set! buf (fx+ i 1)
(fxior #b10000000 (fxand (fxsra b 6) #b111111)))
(bytevector-u8-set! buf (fx+ i 2)
(fxior #b10000000 (fxand b #b111111)))
($set-port-index! p (fx+ i 3))]
[else
(flush-output-port p)
(put-char-utf8-mode p b who)]))]
[else
(let ([i ($port-index p)]
[j ($port-size p)]
[buf ($port-buffer p)])
(cond
[(fx< (fx+ i 3) j)
(bytevector-u8-set! buf i
(fxior #b11110000 (fxsra b 18)))
(bytevector-u8-set! buf (fx+ i 1)
(fxior #b10000000 (fxand (fxsra b 12) #b111111)))
(bytevector-u8-set! buf (fx+ i 2)
(fxior #b10000000 (fxand (fxsra b 6) #b111111)))
(bytevector-u8-set! buf (fx+ i 3)
(fxior #b10000000 (fxand b #b111111)))
($set-port-index! p (fx+ i 4))]
[else
(flush-output-port p)
(put-char-utf8-mode p b who)]))]))
(define (put-char-latin-mode p b who)
(cond
[(fx< b 256)
(flush-output-port p)
(let ([i ($port-index p)] [j ($port-size p)])
(cond
[(fx< i j)
(bytevector-u8-set! ($port-buffer p) i b)
($set-port-index! p (fx+ i 1))]
[else
(die who "insufficient space in port" p)]))]
[else
(case (transcoder-error-handling-mode (port-transcoder p))
[(ignore) (void)]
[(replace) (put-char p #\?)]
[(raise)
(raise (make-i/o-encoding-error p))]
[else (die who "BUG: invalid die handling mode" p)])]))
(define (put-char-char-mode p c who)
(flush-output-port p)
(let ([i ($port-index p)] [j ($port-size p)])
(cond
[(fx< i j)
(string-set! ($port-buffer p) i c)
($set-port-index! p (fx+ i 1))]
[else
(die who "insufficient space in port" p)])))
;;;
(define write-char
(case-lambda
[(c p) (do-put-char p c 'write-char)]
[(c) (do-put-char (*the-output-port*) c 'write-char)]))
(define (put-char p c)
(do-put-char p c 'put-char))
(define (put-string p str)
(unless (string? str) (die 'put-string "not a string" str))
(unless (output-port? p)
(die 'put-string "not an output port" p))
(unless (textual-port? p)
(die 'put-string "not a textual port" p))
(let f ([i 0] [n (string-length str)])
(unless (fx= i n)
(do-put-char p (string-ref str i) 'put-string)
(f (fx+ i 1) n))))
(define (do-put-char p c who)
(unless (char? c) (die who "not a char" c))
(let ([m ($port-fast-attrs p)])
(cond
[(eq? m fast-put-utf8-tag)
(let ([i ($port-index p)])
(let ([b (char->integer c)])
(cond
[(and (fx< i ($port-size p)) (fx< b 128))
(bytevector-u8-set! ($port-buffer p) i b)
($set-port-index! p (fx+ i 1))]
[else
(put-char-utf8-mode p b who)])))]
[(eq? m fast-put-char-tag)
(let ([i ($port-index p)])
(cond
[(fx< i ($port-size p))
($set-port-index! p (fx+ i 1))
(string-set! ($port-buffer p) i c)]
[else
(put-char-char-mode p c who)]))]
[(eq? m fast-put-latin-tag)
(let ([i ($port-index p)])
(let ([b (char->integer c)])
(cond
[(and (fx< i ($port-size p)) (fx< b 256))
(bytevector-u8-set! ($port-buffer p) i b)
($set-port-index! p (fx+ i 1))]
[else
(put-char-latin-mode p b who)])))]
[else
(if (output-port? p)
(die who "not a textual port" p)
(die who "not an output port" p))]))))
(define newline
(case-lambda
[()
(put-char (*the-output-port*) #\newline)
(flush-output-port (*the-output-port*))]
[(p)
(unless (output-port? p)
(die 'newline "not an output port" p))
(unless (textual-port? p)
(die 'newline "not a textual port" p))
(when ($port-closed? p)
(die 'newline "port is closed" p))
(put-char p #\newline)
(flush-output-port p)]))
(module (put-u8)
(import UNSAFE)
(define (put-u8-byte-mode p b who)
(let ([write! ($port-write! p)])
(let ([i ($port-index p)]
[buf ($port-buffer p)])
(let ([bytes (write! buf 0 i)])
(when (or (not (fixnum? bytes))
(fx< bytes 0)
(fx> bytes i))
(die who "write! returned an invalid value" bytes))
(cond
[(fx= bytes i)
(bytevector-u8-set! buf 0 b)
($set-port-index! p 1)]
[(fx= bytes 0)
(die who "could not write bytes to sink")]
[else
(let ([i (fx- i bytes)])
(bytevector-copy! buf bytes buf 0 i)
(bytevector-u8-set! buf i b)
($set-port-index! p (fx+ i 1)))])))))
;;;
(define (put-u8 p b)
(define who 'put-u8)
(unless (u8? b) (die who "not a u8" b))
(let ([m ($port-fast-attrs p)])
(cond
[(eq? m fast-put-byte-tag)
(let ([i ($port-index p)])
(cond
[(fx< i ($port-size p))
($set-port-index! p (fx+ i 1))
(bytevector-u8-set! ($port-buffer p) i b)]
[else
(put-u8-byte-mode p b who)]))]
[else
(if (output-port? p)
(die who "not a binary port" p)
(die who "not an output port" p))]))))
)