238 lines
8.4 KiB
Scheme
238 lines
8.4 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 io output-files)
|
|
(export standard-output-port standard-error-port
|
|
console-output-port current-output-port current-error-port
|
|
open-output-file with-output-to-file call-with-output-file)
|
|
(import
|
|
(ikarus system $ports)
|
|
(ikarus system $io)
|
|
(ikarus system $strings)
|
|
(ikarus system $chars)
|
|
(ikarus system $bytevectors)
|
|
(ikarus system $fx)
|
|
(rnrs bytevectors)
|
|
(except (ikarus)
|
|
standard-output-port standard-error-port
|
|
console-output-port current-output-port current-error-port
|
|
open-output-file with-output-to-file call-with-output-file))
|
|
|
|
(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-output-port p)
|
|
(close-ports))])))
|
|
|
|
(define do-write-buffer
|
|
(lambda (fd port-name buff idx caller)
|
|
(let ([bytes (foreign-call "ikrt_write_file" fd buff idx)])
|
|
(if (fixnum? bytes)
|
|
bytes
|
|
(error caller "cannot write to file" port-name bytes)))))
|
|
|
|
(define make-output-file-handler
|
|
(lambda (fd port-name)
|
|
(define open? #t)
|
|
(define output-file-handler
|
|
(lambda (msg . args)
|
|
(message-case msg args
|
|
[(write-byte b p)
|
|
(if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255))
|
|
(if (output-port? p)
|
|
(let ([idx ($port-index p)])
|
|
(if ($fx< idx ($port-size p))
|
|
(begin
|
|
($bytevector-set! ($port-buffer p) idx b)
|
|
($set-port-index! p ($fxadd1 idx)))
|
|
(if open?
|
|
(let ([bytes (do-write-buffer fd port-name
|
|
($port-buffer p) idx 'write-char)])
|
|
($set-port-index! p 0)
|
|
($write-byte b p))
|
|
(error 'write-byte "port is closed" p))))
|
|
(error 'write-byte "not an output-port" p))
|
|
(error 'write-byte "not a byte" b))]
|
|
[(write-char c p)
|
|
(if (char? c)
|
|
(if (output-port? p)
|
|
(let ([b ($char->fixnum c)])
|
|
(if ($fx<= b 255)
|
|
($write-byte b p)
|
|
(error 'write-char
|
|
"BUG: multibyte write of not implemented" c)))
|
|
(error 'write-char "not an output-port" p))
|
|
(error 'write-char "not a character" c))]
|
|
[(flush-output-port p)
|
|
(if (output-port? p)
|
|
(if open?
|
|
(let ([bytes (do-write-buffer fd port-name
|
|
($port-buffer p)
|
|
($port-index p)
|
|
'flush-output-port)])
|
|
($set-port-index! p 0))
|
|
(error 'flush-output-port "port is closed" p))
|
|
(error 'flush-output-port "not an output-port" p))]
|
|
[(close-port p)
|
|
(when open?
|
|
(flush-output-port p)
|
|
($set-port-size! p 0)
|
|
(set! open? #f)
|
|
(unless (foreign-call "ikrt_close_file" fd)
|
|
(error 'close-output-port "cannot close" port-name)))]
|
|
[(port-name p) port-name]
|
|
[else (error 'output-file-handler
|
|
"unhandled message" (cons msg args))])))
|
|
output-file-handler))
|
|
(define (option-id x)
|
|
(case x
|
|
[(error) 0]
|
|
[(replace) 1]
|
|
[(truncate) 2]
|
|
[(append) 3]
|
|
[else (error 'open-output-file "not a valid mode" x)]))
|
|
|
|
(define $open-output-file
|
|
(lambda (filename options)
|
|
(close-ports)
|
|
(let ([fd/error
|
|
(foreign-call "ikrt_open_output_file"
|
|
(string->utf8 filename)
|
|
(option-id options))])
|
|
(if (fixnum? fd/error)
|
|
(let ([port
|
|
(make-output-port
|
|
(make-output-file-handler fd/error filename)
|
|
($make-bytevector 4096))])
|
|
(guardian port)
|
|
port)
|
|
(error 'open-output-file "cannot open file" filename fd/error)))))
|
|
|
|
(define *standard-output-port* #f)
|
|
|
|
(define *standard-error-port* #f)
|
|
|
|
(define *current-output-port* #f)
|
|
(define *current-error-port* #f)
|
|
|
|
(define standard-output-port
|
|
(lambda () *standard-output-port*))
|
|
|
|
(define standard-error-port
|
|
(lambda () *standard-error-port*))
|
|
|
|
(define console-output-port
|
|
(lambda () *standard-output-port*))
|
|
|
|
(define current-output-port
|
|
(case-lambda
|
|
[() *current-output-port*]
|
|
[(p)
|
|
(if (output-port? p)
|
|
(set! *current-output-port* p)
|
|
(error 'current-output-port "not an output port" p))]))
|
|
|
|
(define current-error-port
|
|
(case-lambda
|
|
[() *current-error-port*]
|
|
[(p)
|
|
(if (output-port? p)
|
|
(set! *current-error-port* p)
|
|
(error 'current-error-port "not an error port" p))]))
|
|
|
|
(define open-output-file
|
|
(case-lambda
|
|
[(filename)
|
|
(if (string? filename)
|
|
($open-output-file filename 'error)
|
|
(error 'open-output-file "not a string" filename))]
|
|
[(filename options)
|
|
(if (string? filename)
|
|
($open-output-file filename options)
|
|
(error 'open-output-file "not a string" filename))]))
|
|
|
|
(define with-output-to-file
|
|
(lambda (name proc . args)
|
|
(unless (string? name)
|
|
(error 'with-output-to-file "not a string" name))
|
|
(unless (procedure? proc)
|
|
(error 'with-output-to-file "not a procedure" proc))
|
|
(let ([p (apply open-output-file name args)]
|
|
[shot #f])
|
|
(call-with-values
|
|
(lambda ()
|
|
(parameterize ([current-output-port p])
|
|
(proc)))
|
|
(case-lambda
|
|
[(v) (close-output-port p) v]
|
|
[v*
|
|
(close-output-port p)
|
|
(apply values v*)])))))
|
|
|
|
(define call-with-output-file
|
|
(lambda (name proc . args)
|
|
(unless (string? name)
|
|
(error 'call-with-output-file "not a string" name))
|
|
(unless (procedure? proc)
|
|
(error 'call-with-output-file "not a procedure" proc))
|
|
(let ([p (apply open-output-file name args)])
|
|
(call-with-values (lambda () (proc p))
|
|
(case-lambda
|
|
[(v) (close-output-port p) v]
|
|
[v*
|
|
(close-output-port p)
|
|
(apply values v*)])))))
|
|
|
|
(set! *standard-output-port*
|
|
(make-output-port
|
|
(make-output-file-handler 1 '*stdout*)
|
|
($make-bytevector 4096)))
|
|
(set! *current-output-port* *standard-output-port*)
|
|
(set! *standard-error-port*
|
|
(make-output-port
|
|
(make-output-file-handler 2 '*stderr*)
|
|
($make-bytevector 4096)))
|
|
(set! *current-error-port* *standard-error-port*)
|
|
|
|
|
|
)
|