ikarus/scheme/ikarus.io.ss

2703 lines
98 KiB
Scheme
Raw Permalink Normal View History

;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008 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/>.
2007-12-05 05:33:31 -05:00
(library (ikarus.io)
2007-12-06 05:05:26 -05:00
(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
2007-12-06 05:05:26 -05:00
open-bytevector-input-port
open-string-input-port open-string-input-port/id
with-input-from-string
2007-12-06 05:05:26 -05:00
make-custom-binary-input-port
2007-12-10 10:36:10 -05:00
make-custom-binary-output-port
make-custom-textual-input-port
make-custom-textual-output-port
transcoded-port port-transcoder
close-port port-closed? 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 read-line
get-u8 lookahead-u8
get-bytevector-n get-bytevector-n!
get-bytevector-some get-bytevector-all
port-position port-has-port-position?
set-port-position! port-has-set-port-position!?
call-with-port
flush-output-port
2008-01-20 20:30:37 -05:00
put-u8 put-bytevector
put-char write-char
put-string
open-bytevector-output-port
call-with-bytevector-output-port
2007-12-23 15:12:22 -05:00
open-string-output-port with-output-to-string
with-output-to-port
call-with-string-output-port
open-output-string get-output-string
standard-output-port standard-error-port
current-output-port current-error-port
2007-12-23 15:18:40 -05:00
open-file-output-port open-output-file
call-with-output-file with-output-to-file
console-output-port
console-error-port
console-input-port
newline
port-mode set-port-mode!
output-port-buffer-mode
reset-input-port!
reset-output-port!
2007-12-10 10:18:52 -05:00
port-id
input-port-byte-position
input-port-column-number input-port-row-number
process process-nonblocking
process*
tcp-connect tcp-connect-nonblocking
udp-connect udp-connect-nonblocking
tcp-server-socket tcp-server-socket-nonblocking
accept-connection accept-connection-nonblocking
close-tcp-server-socket
register-callback
input-socket-buffer-size output-socket-buffer-size
open-directory-stream directory-stream?
read-directory-stream close-directory-stream)
2007-12-05 05:33:31 -05:00
(import
(ikarus system $io)
2007-12-06 05:05:26 -05:00
(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
2007-12-06 05:05:26 -05:00
open-bytevector-input-port
2007-12-23 14:44:55 -05:00
open-string-input-port with-input-from-string
2007-12-06 05:05:26 -05:00
make-custom-binary-input-port
2007-12-10 10:36:10 -05:00
make-custom-binary-output-port
make-custom-textual-input-port
make-custom-textual-output-port
transcoded-port port-transcoder
close-port port-closed? 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 read-line
get-u8 lookahead-u8
get-bytevector-n get-bytevector-n!
get-bytevector-some get-bytevector-all
port-position port-has-port-position?
set-port-position! port-has-set-port-position!?
call-with-port
flush-output-port
2008-01-20 20:30:37 -05:00
put-u8 put-bytevector
put-char write-char
put-string
open-bytevector-output-port
call-with-bytevector-output-port
2007-12-23 15:12:22 -05:00
open-string-output-port with-output-to-string
call-with-string-output-port
open-output-string get-output-string
standard-output-port standard-error-port
current-output-port current-error-port
2007-12-23 15:18:40 -05:00
open-file-output-port open-output-file
call-with-output-file with-output-to-file
with-output-to-port
console-output-port
console-input-port
console-error-port
newline
port-mode set-port-mode!
output-port-buffer-mode
reset-input-port!
reset-output-port!
2007-12-10 10:18:52 -05:00
port-id
process process-nonblocking
tcp-connect tcp-connect-nonblocking
udp-connect udp-connect-nonblocking
tcp-server-socket tcp-server-socket-nonblocking
accept-connection accept-connection-nonblocking
close-tcp-server-socket
register-callback
input-socket-buffer-size output-socket-buffer-size
input-port-column-number input-port-row-number
open-directory-stream directory-stream?
read-directory-stream close-directory-stream
process*
))
;(define-syntax assert* (identifier-syntax assert))
;;; all-data-in-buffer is used in place of the read!
;;; procedure to mark ports whose buffer is all the
;;; data there is.
(define all-data-in-buffer 'all-data-in-buffer)
(define-syntax assert* (syntax-rules () [(_ . x) (void)]))
(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!
bytevector-u16-ref)
2007-12-12 21:22:05 -05:00
(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 (bytevector-u16-ref x i endianness)
(case endianness
[(little)
(fxlogor (bytevector-u8-ref x i)
(fxsll (bytevector-u8-ref x (fx+ i 1)) 8))]
[else
(fxlogor (bytevector-u8-ref x (fx+ i 1))
(fxsll (bytevector-u8-ref x i) 8))])))
2007-12-12 21:22:05 -05:00
(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))]))
2007-12-12 21:22:05 -05:00
(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)))
2007-12-12 18:59:19 -05:00
(define (textual-port? x)
(fx= (fxand ($port-tag x) textual-port-tag) textual-port-tag))
2007-12-05 05:33:31 -05:00
2007-12-12 18:59:19 -05:00
(define (binary-port? x)
(fx= (fxand ($port-tag x) binary-port-tag) binary-port-tag))
2007-12-10 10:18:52 -05:00
2007-12-12 18:59:19 -05:00
(define (output-port? x)
(fx= (fxand ($port-tag x) output-port-tag) output-port-tag))
2007-12-10 10:18:52 -05:00
2007-12-12 18:59:19 -05:00
(define (input-port? x)
(fx= (fxand ($port-tag x) input-port-tag) input-port-tag))
2007-12-10 10:18:52 -05:00
2007-12-12 18:59:19 -05:00
;;; 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 fast-u16be-text-tag #b00000010000000)
(define fast-u16le-text-tag #b00000100000000)
2008-10-21 03:31:44 -04:00
(define init-u16-text-tag #b00000110000000)
; (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-get-utf16be-tag #b00000010000101)
(define fast-get-utf16le-tag #b00000100000101)
(define fast-put-byte-tag #b00000000001010)
(define fast-put-char-tag #b00000000010110)
(define fast-put-utf8-tag #b00000000100110)
(define fast-put-latin-tag #b00000001100110)
2008-10-21 03:31:44 -04:00
(define fast-put-utf16be-tag #b00000010000110)
(define fast-put-utf16le-tag #b00000100000110)
(define init-put-utf16-tag #b00000110000110)
2007-12-10 10:18:52 -05:00
(define fast-attrs-mask #b111111111111)
(define-syntax $port-fast-attrs
(identifier-syntax
(lambda (x)
(import (ikarus system $fx))
($fxlogand ($port-tag x) fast-attrs-mask))))
2007-12-12 21:22:05 -05:00
(define-struct cookie (dest mode pos row-num newline-pos))
(define (default-cookie fd) (make-cookie fd 'ikarus-mode 0 0 0))
2007-12-10 10:18:52 -05:00
(define (port-id p)
(if (port? p)
($port-id p)
(die 'port-id "not a port" p)))
2007-12-10 10:18:52 -05:00
(define (input-port-byte-position p)
(if (input-port? p)
(let ([cookie ($port-cookie p)])
(+ (cookie-pos cookie) (fx+ ($port-index p) 1)))
(error 'input-port-byte-position "not an input port" p)))
(define (mark/return-newline p)
(let ([cookie ($port-cookie p)])
(set-cookie-row-num! cookie (+ (cookie-row-num cookie) 1))
(set-cookie-newline-pos! cookie
(+ (cookie-pos cookie) ($port-index p))))
#\newline)
(define (input-port-column-number p)
(if (input-port? p)
(let ([cookie ($port-cookie p)])
(- (+ (cookie-pos cookie) ($port-index p))
(cookie-newline-pos cookie)))
(die 'input-port-column-number "not an input port" p)))
(define (input-port-row-number p)
(if (input-port? p)
(cookie-row-num ($port-cookie p))
(die 'input-port-row-number "not an input port" p)))
(define (port-position p)
(define who 'port-position)
(if (port? p)
(let ([cookie ($port-cookie p)]
[index ($port-index p)]
[get-position ($port-get-position p)])
(cond
[(procedure? get-position)
(let ([pos (get-position)])
(if (or (fixnum? pos) (bignum? pos))
(if (input-port? p)
(- pos (- ($port-size p) index))
(+ pos index))
(die who "invalid returned value from get-position" p)))]
[(eqv? get-position #t)
(+ (cookie-pos cookie) index)]
[else
(die who "port does not support port-position operation" p)]))
(die who "not a port" p)))
(define (set-port-position! p pos)
(define who 'set-port-position!)
(define (set-position! p pos flush?)
(let ([setpos! ($port-set-position! p)])
(cond
[(procedure? setpos!)
(when flush? (flush-output-port p))
(setpos! pos)
($set-port-index! p 0)
($set-port-size! p 0)
(let ([cookie ($port-cookie p)])
(set-cookie-pos! cookie pos))]
[(eqv? setpos! #t)
(if (<= pos ($port-size p))
($set-port-index! p pos)
(die who "position out of range" pos))]
[else
(die who "port does not support port position" p)])))
(unless (and (or (fixnum? pos) (bignum? pos)) (>= pos 0))
(die who "position must be a nonnegative exact integer" pos))
(cond
[(output-port? p) (set-position! p pos #t)]
[(input-port? p) (set-position! p pos #f)]
[else (die who "not a port" p)]))
(define (port-has-port-position? p)
(define who 'port-has-port-position?)
(if (port? p)
(and ($port-get-position p) #t)
(die who "not a port" p)))
(define (port-has-set-port-position!? p)
(define who 'port-has-set-port-position!?)
(if (port? p)
(and ($port-set-position! p) #t)
(die who "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? (cookie-dest ($port-cookie p)))
(G p))
p)))
(define ($make-custom-binary-port attrs init-size id
2007-12-10 10:36:10 -05:00
read! write! get-position set-position! close buffer-size)
2007-12-06 05:05:26 -05:00
(let ([bv (make-bytevector buffer-size)])
($make-port attrs 0 init-size bv #f id read! write!
get-position set-position! close
(default-cookie #f))))
2007-12-06 05:05:26 -05:00
(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
(default-cookie #f))))
2007-12-06 05:05:26 -05:00
(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))
2007-12-06 05:05:26 -05:00
(unless (procedure? read!)
(die who "read! is not a procedure" read!))
2007-12-06 05:05:26 -05:00
(unless (or (procedure? close) (not close))
(die who "close should be either a procedure or #f" close))
(unless (or (procedure? get-position)
(not get-position))
(die who "get-position is not a procedure or #f"
get-position))
($make-custom-binary-port
2007-12-12 18:59:19 -05:00
binary-input-port-bits
0
id read! #f
get-position
set-position!
close 256))
2007-12-10 10:36:10 -05:00
(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))
2007-12-10 10:36:10 -05:00
(unless (procedure? write!)
(die who "write! is not a procedure" write!))
2007-12-10 10:36:10 -05:00
(unless (or (procedure? close) (not close))
(die who "close should be either a procedure or #f" close))
(unless (or (procedure? get-position)
(not get-position))
(die who "get-position is not a procedure or #f"
get-position))
($make-custom-binary-port
2007-12-12 18:59:19 -05:00
binary-output-port-bits
256
id #f write!
get-position
set-position!
close 256))
2007-12-06 05:05:26 -05:00
(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))
(unless (or (procedure? get-position)
(not get-position))
(die who "get-position is not a procedure or #f"
get-position))
($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))
(unless (or (procedure? get-position)
(not get-position))
(die who "get-position is not a procedure or #f"
get-position))
($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 who)
2007-12-06 05:05:26 -05:00
(cond
[(not x) ;;; binary input port
2007-12-12 18:59:19 -05:00
binary-input-port-bits]
[(not (eq? 'none (transcoder-eol-style x)))
(die who "unsupported transcoder eol-style"
(transcoder-eol-style x))]
[(eq? 'latin-1-codec (transcoder-codec x))
2007-12-12 18:59:19 -05:00
(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.
2007-12-12 18:59:19 -05:00
[else textual-input-port-bits]))
2007-12-06 05:05:26 -05:00
(define (output-transcoder-attrs x who)
(cond
[(not x) ;;; binary input port
2007-12-12 18:59:19 -05:00
binary-output-port-bits]
[(not (eq? 'none (transcoder-eol-style x)))
(die who "unsupported transcoder eol-style"
(transcoder-eol-style x))]
[(eq? 'latin-1-codec (transcoder-codec x))
2007-12-12 18:59:19 -05:00
(fxior textual-output-port-bits fast-u8-text-tag)]
[(eq? 'utf-8-codec (transcoder-codec x))
2007-12-12 18:59:19 -05:00
(fxior textual-output-port-bits fast-u7-text-tag)]
2008-10-21 03:31:44 -04:00
[(eq? 'utf-16-codec (transcoder-codec x))
(fxior textual-output-port-bits fast-u16be-text-tag)]
[else (die who "unsupported codec" (transcoder-codec x))]))
2007-12-06 05:05:26 -05:00
(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
2007-12-06 05:05:26 -05:00
"not a bytevector" bv))
(when (and maybe-transcoder
(not (transcoder? maybe-transcoder)))
(die 'open-bytevector-input-port
2007-12-06 05:05:26 -05:00
"not a transcoder" maybe-transcoder))
($make-port
(input-transcoder-attrs maybe-transcoder
'open-bytevector-output-port)
0 (bytevector-length bv) bv
2007-12-06 05:05:26 -05:00
maybe-transcoder
"*bytevector-input-port*"
all-data-in-buffer ;;; read!
2007-12-06 05:05:26 -05:00
#f ;;; write!
#t ;;; get-position
#t ;;; set-position!
2007-12-06 05:05:26 -05:00
#f ;;; close
(default-cookie #f))]))
2007-12-06 05:05:26 -05:00
(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
'open-bytevector-output-port)
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)
#t ;;; get-position
#f ;;; set-position!
#f ;;; close
(default-cookie #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)))
2007-12-23 15:12:22 -05:00
(define (with-output-to-string proc)
(define who 'with-output-to-string)
(unless (procedure? proc)
(die who "not a procedure" proc))
(let-values ([(p extract) (open-string-output-port)])
(parameterize ([current-output-port p])
2007-12-23 15:12:22 -05:00
(proc))
(extract)))
(define (with-output-to-port p proc)
(define who 'with-output-to-port)
(unless (procedure? proc)
(die who "not a procedure" proc))
(unless (output-port? p)
(die who "not an output port" p))
(unless (textual-port? p)
(die who "not a textual port" p))
(parameterize ([current-output-port p])
(proc)))
(define (open-output-string)
(define who 'open-output-string)
(let ([cookie (default-cookie '())]
[buffer-size 256])
($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-cookie-dest! cookie (cons x (cookie-dest cookie)))))
c)
#t ;;; get-position
#f ;;; set-position!
#f ;;; close!
cookie)))
(define (open-string-output-port)
(let ([p (open-output-string)])
(values
p
(lambda ()
(let ([str (get-output-string p)])
(set-cookie-dest! ($port-cookie p) '())
str)))))
(define (get-output-string-cookie-data cookie)
(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))))])))
(let ([buf* (cookie-dest cookie)])
(let-values ([(bv len) (append-str-buf* buf*)])
bv)))
(define (get-output-string p)
(if (port? p)
(let ([cookie ($port-cookie p)])
(cond
[(and (cookie? cookie)
(let ([x (cookie-dest cookie)])
(or (null? x) (pair? x))))
(unless ($port-closed? p)
(flush-output-port p))
(get-output-string-cookie-data cookie)]
[else
(die 'get-output-string "not an output-string port" p)]))
(die 'get-output-string "not a port" p)))
(define (open-string-input-port/id str id)
2007-12-07 07:39:17 -05:00
(unless (string? str)
(die 'open-string-input-port "not a string" str))
($make-port
(fxior textual-input-port-bits fast-char-text-tag)
0 (string-length str) str
2007-12-11 17:41:48 -05:00
#t ;;; transcoder
id
all-data-in-buffer ;;; read!
2007-12-07 07:39:17 -05:00
#f ;;; write!
#t ;;; get-position
#t ;;; set-position!
2007-12-07 07:39:17 -05:00
#f ;;; close
(default-cookie #f)))