498 lines
16 KiB
Scheme
498 lines
16 KiB
Scheme
|
|
;;; OUTPUT PORTS
|
|
|
|
(let ()
|
|
;;; only file-based ports are supported at this point
|
|
;;;
|
|
;;; an output port is a vector with the following fields:
|
|
;;; 0. id
|
|
;;; 1. file-name
|
|
;;; 2. file-descriptor
|
|
;;; 3. open?
|
|
;;; 4. buffer
|
|
;;; 5. buffer-size
|
|
;;; 6. index
|
|
;;; 7. flush-proc
|
|
;;; 8. close-proc
|
|
(define output-port-id (gensym "output-port"))
|
|
(define output-port?
|
|
(lambda (x)
|
|
(and (vector? x)
|
|
(fx= (vector-length x) 9)
|
|
(eq? (vector-ref x 0) output-port-id))))
|
|
(define output-port-name
|
|
(lambda (p) (vector-ref p 1)))
|
|
(define output-port-fd
|
|
(lambda (p) (vector-ref p 2)))
|
|
(define set-output-port-fd!
|
|
(lambda (p x) (vector-set! p 2 x)))
|
|
(define output-port-open?
|
|
(lambda (p) (vector-ref p 3)))
|
|
(define set-output-port-open?!
|
|
(lambda (p b) (vector-set! p 3 b)))
|
|
(define output-port-buffer
|
|
(lambda (p) (vector-ref p 4)))
|
|
(define set-output-port-buffer!
|
|
(lambda (p b) (vector-set! p 4 b)))
|
|
(define output-port-size
|
|
(lambda (p) (vector-ref p 5)))
|
|
(define output-port-index
|
|
(lambda (p) (vector-ref p 6)))
|
|
(define output-port-flush-proc
|
|
(lambda (p) (vector-ref p 7)))
|
|
(define output-port-close-proc
|
|
(lambda (p) (vector-ref p 8)))
|
|
(define set-output-port-index!
|
|
(lambda (p i) (vector-set! p 6 i)))
|
|
(define fd->port
|
|
(lambda (fd filename)
|
|
(vector output-port-id ; id
|
|
filename
|
|
fd
|
|
#t
|
|
(make-string 4096)
|
|
4096
|
|
0
|
|
fd-flush-proc
|
|
fd-close-proc)))
|
|
(define open-output-string
|
|
(lambda ()
|
|
(vector output-port-id
|
|
'*string-port*
|
|
'()
|
|
#t
|
|
(make-string 4096)
|
|
4096
|
|
0
|
|
str-flush-proc
|
|
(lambda (port) (void)))))
|
|
(define get-output-string
|
|
(lambda (p)
|
|
(define fill
|
|
(lambda (dst src di si sj)
|
|
(cond
|
|
[(fx= si sj) dst]
|
|
[else
|
|
(string-set! dst di (string-ref src si))
|
|
(fill dst src (fxadd1 di) (fxadd1 si) sj)])))
|
|
(unless (output-port? p)
|
|
(error 'get-output-string "~s is not an output port" p))
|
|
(let ([ls (output-port-fd p)])
|
|
(unless (list? ls)
|
|
(error 'get-output-string "~s is not an output port" p))
|
|
(let f ([ls (reverse ls)] [n 0])
|
|
(cond
|
|
[(null? ls)
|
|
(let ([idx (output-port-index p)]
|
|
[buf (output-port-buffer p)])
|
|
(let ([str (make-string (fx+ n idx))])
|
|
(fill str buf n 0 idx)))]
|
|
[else
|
|
(let ([buf (car ls)])
|
|
(let ([idx (string-length buf)])
|
|
(let ([str (f (cdr ls) (fx+ n idx))])
|
|
(fill str buf n 0 idx))))])))))
|
|
(define open-output-file
|
|
(lambda (name mode)
|
|
(unless (string? name)
|
|
(error 'open-output-file "~s is not a valid file name" name))
|
|
(let ([mode
|
|
(cond
|
|
[(assq mode '([error 0] [append 1] [replace 2] [truncate 3]))
|
|
=> cadr]
|
|
[else
|
|
(error 'open-output-file "~s is not a valid mode" mode)])])
|
|
(let ([fh (foreign-call "ik_open_file" name mode)])
|
|
(fd->port fh name)))))
|
|
(define write-char
|
|
(lambda (c port)
|
|
(unless (char? c)
|
|
(error 'write-char "not a char: ~s" c))
|
|
(unless (output-port-open? port)
|
|
(error 'write-char "port ~s closed" port))
|
|
(let ([idx (output-port-index port)] [size (output-port-size port)])
|
|
(if (fx< idx size)
|
|
(begin
|
|
(string-set! (output-port-buffer port) idx c)
|
|
(set-output-port-index! port (fxadd1 idx))
|
|
(when ($char= c #\newline)
|
|
(flush-output-port port)))
|
|
(begin
|
|
(flush-output-port port)
|
|
(write-char c port))))))
|
|
(define fd-flush-proc
|
|
(lambda (port)
|
|
(let ([idx (output-port-index port)])
|
|
(when (fx> idx 0)
|
|
(foreign-call "ik_write"
|
|
(output-port-fd port)
|
|
idx
|
|
(output-port-buffer port))))
|
|
(set-output-port-index! port 0)))
|
|
(define str-flush-proc
|
|
(lambda (port)
|
|
(let ([idx (output-port-index port)])
|
|
(when (fx> idx 0)
|
|
(let ([str (output-port-buffer port)])
|
|
(when (fx= idx (string-length str))
|
|
(set-output-port-fd! port
|
|
(cons str (output-port-fd port)))
|
|
(set-output-port-buffer! port
|
|
(make-string (string-length str)))
|
|
(set-output-port-index! port 0)))))))
|
|
(define fd-close-proc
|
|
(lambda (port)
|
|
(let ([idx (output-port-index port)])
|
|
(when (fx> idx 0)
|
|
(foreign-call "ik_write"
|
|
(output-port-fd port)
|
|
idx
|
|
(output-port-buffer port))))
|
|
(foreign-call "ik_close" (output-port-fd port))))
|
|
|
|
(define flush-output-port
|
|
(lambda (port)
|
|
(unless (output-port-open? port)
|
|
(error 'flush-output-port "port ~s closed" port))
|
|
((output-port-flush-proc port) port)))
|
|
(define close-output-port
|
|
(lambda (port)
|
|
(when (output-port-open? port)
|
|
((output-port-close-proc port) port)
|
|
(set-output-port-open?! port #f))))
|
|
|
|
;;; init section
|
|
(primitive-set! 'close-output-port
|
|
(case-lambda
|
|
[() (close-output-port (current-output-port))]
|
|
[(p)
|
|
(unless (output-port? p)
|
|
(error 'close-output-port "~s is not an output port" p))
|
|
(close-output-port p)]))
|
|
(primitive-set! 'output-port? output-port?)
|
|
(primitive-set! 'open-output-file
|
|
(case-lambda
|
|
[(filename) (open-output-file filename 'error)]
|
|
[(filename mode) (open-output-file filename mode)]))
|
|
(primitive-set! 'write-char
|
|
(case-lambda
|
|
[(c) (write-char c (current-output-port))]
|
|
[(c p)
|
|
(unless (output-port? p)
|
|
(error 'write-char "~s is not an output port" p))
|
|
(write-char c p)]))
|
|
(primitive-set! 'flush-output-port
|
|
(case-lambda
|
|
[() (flush-output-port (current-output-port))]
|
|
[(p)
|
|
(unless (output-port? p)
|
|
(error 'flush-output-port "~s is not an output port" p))
|
|
(flush-output-port p)]))
|
|
(primitive-set! 'standard-output-port
|
|
(let ([p (fd->port 1 '*stdout*)])
|
|
(lambda () p)))
|
|
(primitive-set! 'standard-error-port
|
|
(let ([p (fd->port 2 '*stderr*)])
|
|
(lambda () p)))
|
|
(primitive-set! 'current-output-port
|
|
(make-parameter (standard-output-port)
|
|
(lambda (p)
|
|
(unless (output-port? p)
|
|
(error 'current-output-port "not a port ~s" p))
|
|
p)))
|
|
(primitive-set! 'console-output-port
|
|
(make-parameter (standard-output-port)
|
|
(lambda (p)
|
|
(unless (output-port? p)
|
|
(error 'console-output-port "not a port ~s" p))
|
|
p)))
|
|
(primitive-set! 'newline
|
|
(case-lambda
|
|
[() (write-char #\newline (current-output-port))]
|
|
[(p)
|
|
(unless (output-port? p)
|
|
(error 'newline "~s is not an output port" p))
|
|
(write-char #\newline p)]))
|
|
|
|
(primitive-set! 'open-output-string open-output-string)
|
|
(primitive-set! 'get-output-string get-output-string)
|
|
(primitive-set! 'output-port-name
|
|
(lambda (x)
|
|
(if (output-port? x)
|
|
(output-port-name x)
|
|
(error 'output-port-name "~s is not an output port" x)))))
|
|
|
|
;;; INPUT PORTS
|
|
|
|
(let ()
|
|
;;; input ports are similar to output ports, with the exception of
|
|
;;; the ungetchar buffer
|
|
;;; Fields:
|
|
;;; 0. id
|
|
;;; 1. file-name
|
|
;;; 2. file-descriptor
|
|
;;; 3. open?
|
|
;;; 4. buffer
|
|
;;; 5. buffer-size
|
|
;;; 6. index
|
|
;;; 7. unget
|
|
(define input-port-id (gensym "input-port"))
|
|
(define input-port?
|
|
(lambda (x)
|
|
(and (vector? x)
|
|
(fx= (vector-length x) 8)
|
|
(eq? (vector-ref x 0) input-port-id))))
|
|
(define input-port-name
|
|
(lambda (x)
|
|
(vector-ref x 1)))
|
|
(define input-port-fd
|
|
(lambda (x)
|
|
(vector-ref x 2)))
|
|
(define input-port-open?
|
|
(lambda (x)
|
|
(vector-ref x 3)))
|
|
(define input-port-buffer
|
|
(lambda (x)
|
|
(vector-ref x 4)))
|
|
(define input-port-size
|
|
(lambda (x)
|
|
(vector-ref x 5)))
|
|
(define set-input-port-size!
|
|
(lambda (x i)
|
|
(vector-set! x 5 i)))
|
|
(define input-port-index
|
|
(lambda (x)
|
|
(vector-ref x 6)))
|
|
(define set-input-port-index!
|
|
(lambda (x i)
|
|
(vector-set! x 6 i)))
|
|
(define set-input-port-returned-char!
|
|
(lambda (x i)
|
|
(vector-set! x 7 i)))
|
|
(define input-port-returned-char
|
|
(lambda (x)
|
|
(vector-ref x 7)))
|
|
(define fd->port
|
|
(lambda (fd filename)
|
|
(vector input-port-id
|
|
filename
|
|
fd
|
|
#t
|
|
(make-string 4096)
|
|
0
|
|
0
|
|
#f)))
|
|
(define open-input-file
|
|
(lambda (filename)
|
|
(unless (string? filename)
|
|
(error 'open-input-file "not a string: ~s" filename))
|
|
(let ([fd (foreign-call "ik_open_file" filename 4)])
|
|
(fd->port fd filename))))
|
|
(define close-input-port
|
|
(lambda port
|
|
(let ([port
|
|
(if (null? port)
|
|
(current-input-port)
|
|
(if (null? ($cdr port))
|
|
(let ([p ($car port)])
|
|
(if (input-port? p)
|
|
p
|
|
(error 'close-input-port "not an input port: ~s" p)))
|
|
(error 'close-input-port "too many arguments")))])
|
|
(foreign-call "ik_close" (input-port-fd port))
|
|
(void))))
|
|
(define read-char
|
|
(lambda (port)
|
|
(unless (input-port-open? port)
|
|
(error 'read-char "port closed"))
|
|
(cond
|
|
[(input-port-returned-char port) =>
|
|
(lambda (c)
|
|
(set-input-port-returned-char! port #f)
|
|
c)]
|
|
[else
|
|
(let ([idx (input-port-index port)]
|
|
[size (input-port-size port)]
|
|
[buf (input-port-buffer port)])
|
|
(if ($fx< idx size)
|
|
(let ([c ($string-ref buf idx)])
|
|
(set-input-port-index! port ($fxadd1 idx))
|
|
c)
|
|
(let ([bytes
|
|
(foreign-call "ik_read"
|
|
(input-port-fd port)
|
|
buf
|
|
($string-length buf))])
|
|
(set-input-port-size! port bytes)
|
|
(if ($fxzero? bytes)
|
|
(begin
|
|
(set-input-port-index! port 0)
|
|
(eof-object))
|
|
(begin
|
|
(let ([c ($string-ref buf 0)])
|
|
(set-input-port-index! port 1)
|
|
c))))))])))
|
|
(define peek-char
|
|
(lambda (port)
|
|
(unless (input-port-open? port)
|
|
(error 'peek-char "port closed"))
|
|
(cond
|
|
[(input-port-returned-char port) =>
|
|
(lambda (c) c)]
|
|
[else
|
|
(let ([idx (input-port-index port)]
|
|
[size (input-port-size port)]
|
|
[buf (input-port-buffer port)])
|
|
(if (fx< idx size)
|
|
(string-ref buf idx)
|
|
(let ([bytes
|
|
(foreign-call "ik_read"
|
|
(input-port-fd port)
|
|
buf
|
|
($string-length buf))])
|
|
(set-input-port-size! port bytes)
|
|
(set-input-port-index! port 0)
|
|
(if (fxzero? bytes)
|
|
(eof-object)
|
|
(string-ref buf 0)))))])))
|
|
(define reset-input-port!
|
|
(lambda (p)
|
|
(unless (input-port? p)
|
|
(error 'reset-input-port! "~s is not an input port" p))
|
|
(set-input-port-index! p 0)
|
|
(set-input-port-size! p 0)
|
|
(set-input-port-returned-char! p #f)))
|
|
(define unread-char
|
|
(lambda (c port)
|
|
(unless (char? c)
|
|
(error 'unread-char "not a character ~s" c))
|
|
(unless (input-port-open? port)
|
|
(error 'unread-char "port closed"))
|
|
(when (input-port-returned-char port)
|
|
(error 'unread-char "cannot unread twice"))
|
|
(set-input-port-returned-char! port c)))
|
|
(primitive-set! 'open-input-file open-input-file)
|
|
(primitive-set! 'close-input-port
|
|
(case-lambda
|
|
[() (close-input-port (current-input-port))]
|
|
[(p)
|
|
(unless (input-port? p)
|
|
(error 'close-input-port "~s is not an input port" p))
|
|
(close-input-port p)]))
|
|
(primitive-set! 'input-port? input-port?)
|
|
(primitive-set! 'read-char
|
|
(case-lambda
|
|
[() (read-char (current-input-port))]
|
|
[(p)
|
|
(unless (input-port? p)
|
|
(error 'read-char "~s is not an input port" p))
|
|
(read-char p)]))
|
|
(primitive-set! 'peek-char
|
|
(case-lambda
|
|
[() (peek-char (current-input-port))]
|
|
[(p)
|
|
(unless (input-port? p)
|
|
(error 'peek-char "~s is not an input port" p))
|
|
(peek-char p)]))
|
|
(primitive-set! 'unread-char
|
|
(case-lambda
|
|
[(c) (unread-char c (current-input-port))]
|
|
[(c p)
|
|
(unless (input-port? p)
|
|
(error 'unread-char "~s is not an input port" p))
|
|
(unread-char c p)]))
|
|
(primitive-set! 'standard-input-port
|
|
(let ([p (fd->port 0 '*stdin*)])
|
|
(lambda () p)))
|
|
(primitive-set! 'current-input-port
|
|
(make-parameter (standard-input-port)
|
|
(lambda (x)
|
|
(unless (input-port? x)
|
|
(error 'current-input-port "not an input port ~s" x))
|
|
x)))
|
|
(primitive-set! 'console-input-port
|
|
(make-parameter (standard-input-port)
|
|
(lambda (x)
|
|
(unless (input-port? x)
|
|
(error 'console-input-port "not an input port ~s" x))
|
|
x)))
|
|
(primitive-set! 'input-port-name
|
|
(lambda (x)
|
|
(if (input-port? x)
|
|
(input-port-name x)
|
|
(error 'input-port-name "~s is not an input port" x))))
|
|
(primitive-set! 'reset-input-port! reset-input-port!))
|
|
|
|
(primitive-set! 'with-output-to-file
|
|
(lambda (name proc . args)
|
|
(unless (string? name)
|
|
(error 'with-output-to-file "~s is not a string" name))
|
|
(unless (procedure? proc)
|
|
(error 'with-output-to-file "~s is not a procedure" proc))
|
|
(let ([p (apply open-output-file name args)]
|
|
[shot #f])
|
|
(parameterize ([current-output-port p])
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(when shot
|
|
(error 'with-output-to-file
|
|
"cannot reenter")))
|
|
proc
|
|
(lambda ()
|
|
(close-output-port p)
|
|
(set! shot #t)))))))
|
|
|
|
(primitive-set! 'call-with-output-file
|
|
(lambda (name proc . args)
|
|
(unless (string? name)
|
|
(error 'call-with-output-file "~s is not a string" name))
|
|
(unless (procedure? proc)
|
|
(error 'call-with-output-file "~s is not a procedure" proc))
|
|
(let ([p (apply open-output-file name args)]
|
|
[shot #f])
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(when shot
|
|
(error 'call-with-output-file "cannot reenter")))
|
|
(lambda () (proc p))
|
|
(lambda ()
|
|
(close-output-port p)
|
|
(set! shot #t))))))
|
|
|
|
(primitive-set! 'with-input-from-file
|
|
(lambda (name proc . args)
|
|
(unless (string? name)
|
|
(error 'with-input-from-file "~s is not a string" name))
|
|
(unless (procedure? proc)
|
|
(error 'with-input-from-file "~s is not a procedure" proc))
|
|
(let ([p (apply open-input-file name args)]
|
|
[shot #f])
|
|
(parameterize ([current-input-port p])
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(when shot
|
|
(error 'with-input-from-file
|
|
"cannot reenter")))
|
|
proc
|
|
(lambda ()
|
|
(close-input-port p)
|
|
(set! shot #t)))))))
|
|
|
|
(primitive-set! 'call-with-input-file
|
|
(lambda (name proc . args)
|
|
(unless (string? name)
|
|
(error 'call-with-input-file "~s is not a string" name))
|
|
(unless (procedure? proc)
|
|
(error 'call-with-input-file "~s is not a procedure" proc))
|
|
(let ([p (apply open-input-file name args)]
|
|
[shot #f])
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(when shot
|
|
(error 'call-with-input-file "cannot reenter")))
|
|
(lambda () (proc p))
|
|
(lambda ()
|
|
(close-input-port p)
|
|
(set! shot #t))))))
|
|
|