ikarus/scheme/ikarus.io.input-files.ss

254 lines
9.3 KiB
Scheme
Raw Normal View History

;;; 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 io input-files)
(export open-input-file current-input-port console-input-port
with-input-from-file call-with-input-file)
(import
2007-05-06 18:30:08 -04:00
(ikarus system $ports)
(ikarus system $io)
(ikarus system $fx)
(ikarus system $strings)
(ikarus system $bytevectors)
2007-05-06 18:30:08 -04:00
(ikarus system $chars)
2007-10-12 00:33:19 -04:00
(rnrs bytevectors)
(except (ikarus)
open-input-file current-input-port console-input-port
with-input-from-file call-with-input-file
*standard-input-port* *current-input-port*))
(define-syntax message-case
(syntax-rules (else)
[(_ msg args
[(msg-name msg-arg* ...) b b* ...] ...
[else else1 else2 ...])
(let ([tmsg msg] [targs args])
(define-syntax match-and-bind
(syntax-rules ()
[(__ y () body)
(if (null? y)
body
(error 'message-case "unmatched" (cons tmsg targs)))]
[(__ y (a a* (... ...)) body)
(if (pair? y)
(let ([a (car y)] [d (cdr y)])
(match-and-bind d (a* (... ...)) body))
(error 'message-case "unmatched" (cons tmsg targs)))]))
(case tmsg
[(msg-name)
(match-and-bind targs (msg-arg* ...) (begin b b* ...))] ...
[else else1 else2 ...]))]))
(define guardian (make-guardian))
(define close-ports
(lambda ()
(cond
[(guardian) =>
(lambda (p)
(close-input-port p)
(close-ports))])))
(define refill-buffer!
(lambda (p bytes)
(error 'refill-buffer! "not implemented")))
(define read-multibyte-char
(lambda (p b0)
(let ([idx ($port-index p)]
[size ($port-size p)])
(cond
[($fx= ($fxlogand b0 #b11100000) #b11000000)
;;; 2-byte utf8 sequence
(unless ($fx< ($fx+ idx 1) size)
(refill-buffer! p 1))
(let ([b1 ($bytevector-u8-ref
($port-buffer p)
($fxadd1 idx))])
(unless ($fx= ($fxlogand b1 #b11000000) #b10000000)
(error 'read-char "invalid utf8 sequence" b0 b1))
($set-port-index! p ($fx+ idx 2))
($fixnum->char
($fx+ ($fxsll ($fxlogand b0 #b11111) 6)
($fxlogand b1 #b111111))))]
[else
(error 'read-multibyte
"BUG: bytesequence is not supported yet" b0)]))))
(define peek-multibyte-char
(lambda (p)
(error 'peek-multibyte-char "not implemented")))
(define unread-multibyte-char
(lambda (c p)
(error 'unread-multibyte-char "not implemented")))
(define make-input-file-handler
(lambda (fd port-name)
(let ((open? #t))
(lambda (msg . args)
(message-case msg args
[(read-char p)
(unless (input-port? p)
(error 'read-char "not an input port" p))
(let ([idx ($port-index p)])
(if ($fx< idx ($port-size p))
(let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
(cond
[($fx< b 128)
($set-port-index! p ($fxadd1 idx))
($fixnum->char b)]
[else (read-multibyte-char p b)]))
(if open?
(let ([bytes
(foreign-call "ikrt_read"
fd ($port-buffer p))])
(cond
[($fx> bytes 0)
($set-port-size! p bytes)
($read-char p)]
[($fx= bytes 0)
(eof-object)]
[else
(error 'read-char "Cannot read from file"
port-name)]))
(error 'read-char "port is closed" p))))]
[(peek-char p)
(unless (input-port? p)
(error 'peek-char "not an input port" p))
(let ([idx ($port-index p)])
(if ($fx< idx ($port-size p))
(let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
(cond
[($fx< b 128) ($fixnum->char b)]
[else (peek-multibyte-char p)]))
(if open?
(let ([bytes
(foreign-call "ikrt_read" fd
(port-input-buffer p))])
(cond
[(not bytes)
(error 'peek-char
"Cannot read from file" port-name)]
[($fx= bytes 0)
(eof-object)]
[else
($set-port-size! p bytes)
($peek-char p)]))
(error 'peek-char "port is closed" p))))]
[(unread-char c p)
(unless (input-port? p)
(error 'unread-char "not an input port" p))
(let ([idx ($fxsub1 ($port-index p))]
[b (if (char? c)
($char->fixnum c)
(error 'unread-char "not a char" c))])
(if (and ($fx>= idx 0)
($fx< idx ($port-size p)))
(cond
[($fx< b 128)
($set-port-index! p idx)]
[else (unread-multibyte-char c p)])
(if open?
(error 'unread-char "port is closed" p)
(error 'unread-char "too many unread-chars"))))]
[(port-name p) port-name]
[(close-port p)
(unless (input-port? p)
(error 'close-input-port "not an input port" p))
(when open?
($set-port-size! p 0)
(set! open? #f)
(unless (foreign-call "ikrt_close_file" fd)
(error 'close-input-port "cannot close port" port-name)))]
[else
(error 'input-file-handler
"message not handled" (cons msg args))])))))
(define $open-input-file
(lambda (filename)
(close-ports)
(let ([fd/error (foreign-call "ikrt_open_input_file"
2007-10-12 00:33:19 -04:00
(string->utf8 filename))])
(if (fixnum? fd/error)
(let ([port (make-input-port
(make-input-file-handler fd/error filename)
($make-bytevector 4096))])
(set-port-input-size! port 0)
(guardian port)
port)
(error 'open-input-file "cannot open file"
filename fd/error)))))
(define open-input-file
(lambda (filename)
(if (string? filename)
($open-input-file filename)
(error 'open-input-file "not a string" filename))))
(define with-input-from-file
(lambda (name proc)
(unless (string? name)
(error 'with-input-from-file "not a string" name))
(unless (procedure? proc)
(error 'with-input-from-file "not a procedure" proc))
(let ([p ($open-input-file name)])
(call-with-values
(lambda ()
(parameterize ([current-input-port p])
(proc)))
(case-lambda
[(v) (close-input-port p) v]
[v*
(close-input-port p)
(apply values v*)])))))
(define call-with-input-file
(lambda (name proc)
(unless (string? name)
(error 'call-with-input-file "not a string" name))
(unless (procedure? proc)
(error 'call-with-input-file "not a procedure" proc))
(let ([p ($open-input-file name)])
(call-with-values (lambda () (proc p))
(case-lambda
[(v) (close-input-port p) v]
[v*
(close-input-port p)
(apply values v*)])))))
(define *standard-input-port* #f)
(define *current-input-port* #f)
(define console-input-port
(lambda () *standard-input-port*))
(define current-input-port
(case-lambda
[() *current-input-port*]
[(p)
(if (input-port? p)
(set! *current-input-port* p)
(error 'current-input-port "not an input-port" p))]))
(set! *standard-input-port*
(let ([p (make-input-port
(make-input-file-handler 0 '*stdin*)
($make-bytevector 4096))])
(set-port-input-size! p 0)
p))
(set! *current-input-port* *standard-input-port*)
)