ikarus/lib/libchezio.ss

735 lines
26 KiB
Scheme
Raw Normal View History

2006-11-23 19:44:29 -05:00
(let ()
(include "unsafe-record.ss")
;;;
;;; GENERIC PORTS: BASIC PRIMITIVES
;;;
;;; Exports:
;;; * Constructors:
;;; (make-input-port handler input-buffer)
;;; (make-output-port handler output-buffer)
;;; (make-input/output-port handler input-buffer output-buffer)
;;;
;;; * Predicates:
;;; (port? x)
;;; (input-port? x)
;;; (output-port? x)
;;;
;;; * Accessors:
;;; (port-handler port)
;;; (port-input-buffer port)
;;; (port-input-index port)
;;; (port-input-size port)
;;; (port-output-buffer port)
;;; (port-output-index port)
;;; (port-output-size port)
;;;
;;; * Mutators:
2006-11-23 19:48:14 -05:00
;;; (set-port-handler! port proc)
;;; (set-port-input-buffer! port string)
2006-11-23 19:44:29 -05:00
;;; (set-port-input-index! port fixnum)
;;; (set-port-input-size! port fixnum)
2006-11-23 19:48:14 -05:00
;;; (set-port-output-buffer! port string)
2006-11-23 19:44:29 -05:00
;;; (set-port-output-index! port fixnum)
;;; (set-port-output-size! port fixnum)
;;;
(primitive-set! 'port?
(lambda (x) (port? x)))
;;;
(primitive-set! 'input-port?
(lambda (x) (input-port? x)))
;;;
(primitive-set! 'output-port?
(lambda (x) (output-port? x)))
;;;
(primitive-set! '$make-input-port
(lambda (handler buffer)
2006-11-23 19:48:14 -05:00
($make-port/input handler buffer 0 ($string-length buffer) #f 0 0)))
2006-11-23 19:44:29 -05:00
;;;
(primitive-set! 'make-input-port
(lambda (handler buffer)
(if (procedure? handler)
(if (string? buffer)
($make-input-port handler buffer)
(error 'make-input-port "~s is not a string" buffer))
(error 'make-input-port "~s is not a procedure" handler))))
;;;
(primitive-set! '$make-output-port
(lambda (handler buffer)
2006-11-23 19:48:14 -05:00
($make-port/output handler #f 0 0 buffer 0 ($string-length buffer))))
2006-11-23 19:44:29 -05:00
;;;
(primitive-set! 'make-output-port
(lambda (handler buffer)
(if (procedure? handler)
(if (string? buffer)
($make-output-port handler buffer)
(error 'make-output-port "~s is not a string" buffer))
(error 'make-output-port "~s is not a procedure" handler))))
;;;
(primitive-set! '$make-input/output-port
(lambda (handler input-buffer output-buffer)
2006-11-23 19:48:14 -05:00
($make-port/both handler
2006-11-23 19:44:29 -05:00
input-buffer 0 ($string-length input-buffer)
output-buffer 0 ($string-length output-buffer))))
(primitive-set! 'make-input/output-port
(lambda (handler input-buffer output-buffer)
(if (procedure? handler)
(if (string? input-buffer)
(if (string? output-buffer)
($make-input/output-port handler input-buffer output-buffer)
(error 'make-input/output-port
"~s is not a string"
output-buffer))
(error 'make-input/output-port "~s is not a string" input-buffer))
(error 'make-input/output-port "~s is not a procedure" handler))))
;;;
(primitive-set! '$port-handler
(lambda (x) ($port-handler x)))
;;;
(primitive-set! 'port-handler
(lambda (x)
(if (port? x)
($port-handler x)
(error 'port-handler "~s is not a port" x))))
;;;
(primitive-set! '$port-input-buffer
(lambda (x) ($port-input-buffer x)))
;;;
(primitive-set! 'port-input-buffer
(lambda (x)
(if (input-port? x)
($port-input-buffer x)
(error 'port-input-buffer "~s is not an input-port" x))))
;;;
(primitive-set! '$port-input-index
(lambda (x) ($port-input-index x)))
;;;
(primitive-set! 'port-input-index
(lambda (x)
(if (input-port? x)
($port-input-index x)
(error 'port-input-index "~s is not an input-port" x))))
;;;
(primitive-set! '$port-input-size
(lambda (x) ($port-input-size x)))
;;;
(primitive-set! 'port-input-size
(lambda (x)
(if (input-port? x)
($port-input-size x)
(error 'port-input-size "~s is not an input-port" x))))
;;;
(primitive-set! '$port-output-buffer
(lambda (x) ($port-output-buffer x)))
;;;
(primitive-set! 'port-output-buffer
(lambda (x)
(if (output-port? x)
($port-output-buffer x)
(error 'port-output-buffer "~s is not an output-port" x))))
;;;
(primitive-set! '$port-output-index
(lambda (x) ($port-output-index x)))
;;;
(primitive-set! 'port-output-index
(lambda (x)
(if (output-port? x)
($port-output-index x)
(error 'port-output-index "~s is not an output-port" x))))
;;;
(primitive-set! '$port-output-size
(lambda (x) ($port-output-size x)))
;;;
(primitive-set! 'port-output-size
(lambda (x)
(if (output-port? x)
($port-output-size x)
(error 'port-output-size "~s is not an output-port" x))))
;;;
(primitive-set! '$set-port-input-index!
(lambda (p i) ($set-port-input-index! p i)))
;;;
(primitive-set! 'set-port-input-index!
(lambda (p i)
(if (input-port? p)
(if (fixnum? i)
(if ($fx>= i 0)
(if ($fx<= i ($port-input-size p))
($set-port-input-index! p i)
(error 'set-port-input-index! "index ~s is too big" i))
(error 'set-port-input-index! "index ~s is negative" i))
(error 'set-port-input-index! "~s is not a valid index" i))
(error 'set-port-input-index! "~s is not an input-port" p))))
;;;
(primitive-set! '$set-port-input-size!
(lambda (p i)
($set-port-input-index! p 0)
($set-port-input-size! p i)))
;;;
(primitive-set! 'set-port-input-size!
(lambda (p i)
(if (input-port? p)
(if (fixnum? i)
(if ($fx>= i 0)
(if ($fx<= i ($string-length ($port-input-buffer p)))
(begin
($set-port-input-index! p 0)
($set-port-input-size! p i))
(error 'set-port-input-size! "size ~s is too big" i))
(error 'set-port-input-size! "size ~s is negative" i))
(error 'set-port-input-size! "~s is not a valid size" i))
(error 'set-port-input-size! "~s is not an input-port" p))))
;;;
(primitive-set! '$set-port-output-index!
(lambda (p i) ($set-port-output-index! p i)))
;;;
(primitive-set! 'set-port-output-index!
(lambda (p i)
(if (output-port? p)
(if (fixnum? i)
(if ($fx>= i 0)
(if ($fx<= i ($port-output-size p))
($set-port-output-index! p i)
(error 'set-port-output-index! "index ~s is too big" i))
(error 'set-port-output-index! "index ~s is negative" i))
(error 'set-port-output-index! "~s is not a valid index" i))
(error 'set-port-output-index! "~s is not an output-port" p))))
;;;
(primitive-set! '$set-port-output-size!
(lambda (p i)
($set-port-output-index! p 0)
($set-port-output-size! p i)))
;;;
(primitive-set! 'set-port-output-size!
(lambda (p i)
(if (output-port? p)
(if (fixnum? i)
(if ($fx>= i 0)
(if ($fx<= i ($string-length ($port-output-buffer p)))
(begin
($set-port-output-index! p 0)
($set-port-output-size! p i))
(error 'set-port-output-size! "size ~s is too big" i))
(error 'set-port-output-size! "size ~s is negative" i))
(error 'set-port-output-size! "~s is not a valid size" i))
(error 'set-port-output-size! "~s is not an output-port" p)))))
(let ()
;;; IO PRIMITIVES
;;;
(primitive-set! '$write-char
(lambda (c p)
2006-11-23 19:48:14 -05:00
(let ([idx (port-output-index p)])
2006-11-23 19:44:29 -05:00
(if ($fx< idx ($port-output-size p))
(begin
($string-set! ($port-output-buffer p) idx c)
($set-port-output-index! p ($fxadd1 idx)))
(($port-handler p) 'write-char c p)))))
;;;
(primitive-set! 'write-char
(case-lambda
[(c)
(if (char? c)
($write-char c (current-output-port))
(error 'write-char "~s is not a character" c))]
[(c p)
(if (char? c)
(if (output-port? p)
($write-char c p)
(error 'write-char "~s is not an output-port" p))
(error 'write-char "~s is not a character" c))]))
;;;
(primitive-set! 'newline
(case-lambda
[()
($write-char #\newline (current-output-port))
($flush-output-port (current-output-port))]
[(p)
(if (output-port? p)
(begin
($write-char #\newline p)
($flush-output-port p))
(error 'newline "~s is not an output port" p))]))
;;;
(primitive-set! 'port-name
(lambda (p)
(if (port? p)
(($port-handler p) 'port-name p)
(error 'port-name "~s is not a port" p))))
(primitive-set! 'input-port-name port-name)
(primitive-set! 'output-port-name port-name)
(primitive-set! '$read-char
(lambda (p)
(let ([idx ($port-input-index p)])
(if ($fx< idx ($port-input-size p))
(begin
($set-port-input-index! p ($fxadd1 idx))
($string-ref ($port-input-buffer p) idx))
(begin
(($port-handler p) 'read-char p))))))
;;;
(primitive-set! 'read-char
(case-lambda
2006-11-23 19:48:14 -05:00
[() ($read-char *current-input-port*)]
2006-11-23 19:44:29 -05:00
[(p)
(if (input-port? p)
($read-char p)
(error 'read-char "~s is not an input-port" p))]))
;;;
(primitive-set! '$unread-char
(lambda (c p)
(let ([idx ($fxsub1 ($port-input-index p))])
(if (and ($fx>= idx 0)
($fx< idx ($port-input-size p)))
(begin
($set-port-input-index! p idx)
($string-set! ($port-input-buffer p) idx c))
(($port-handler p) 'unread-char c p)))))
;;;
(primitive-set! 'unread-char
(case-lambda
[(c) (if (char? c)
($unread-char c (current-input-port))
(error 'unread-char "~s is not a character" c))]
[(c p)
(if (input-port? p)
(if (char? c)
($unread-char c p)
(error 'unread-char "~s is not a character" c))
(error 'unread-char "~s is not an input-port" p))]))
;;;
(primitive-set! '$peek-char
(lambda (p)
(let ([idx ($port-input-index p)])
(if ($fx< idx ($port-input-size p))
($string-ref ($port-input-buffer p) idx)
(($port-handler p) 'peek-char p)))))
;;;
(primitive-set! 'peek-char
(case-lambda
[() ($peek-char (current-input-port))]
[(p)
(if (input-port? p)
($peek-char p)
(error 'peek-char "~s is not an input-port" p))]))
;;;
(primitive-set! '$unread-char
(lambda (c p)
(let ([idx ($fxsub1 ($port-input-index p))])
(if (and ($fx>= idx 0)
($fx< idx ($port-input-size p)))
(begin
($set-port-input-index! p idx)
($string-set! ($port-input-buffer p) idx c))
(($port-handler p) 'unread-char c p)))))
;;;
(primitive-set! '$reset-input-port!
(lambda (p)
($set-port-input-size! p 0)))
;;;
(primitive-set! 'reset-input-port!
(case-lambda
[() ($reset-input-port! (current-input-port))]
[(p)
(if (input-port? p)
($reset-input-port! p)
(error 'reset-input-port! "~s is not an input-port" p))]))
;;;
(primitive-set! '$close-input-port
(lambda (p)
(($port-handler p) 'close-port p)))
;;;
(primitive-set! 'close-input-port
(case-lambda
[() ($close-input-port (current-input-port))]
[(p)
(if (input-port? p)
($close-input-port p)
(error 'close-input-port! "~s is not an input-port" p))]))
;;;
(primitive-set! '$close-output-port
(lambda (p)
(($port-handler p) 'close-port p)))
;;;
(primitive-set! 'close-output-port
(case-lambda
[() ($close-output-port (current-output-port))]
[(p)
(if (output-port? p)
($close-output-port p)
(error 'close-output-port "~s is not an output-port" p))]))
;;;
(primitive-set! '$flush-output-port
(lambda (p)
(($port-handler p) 'flush-output-port p)))
;;;
(primitive-set! 'flush-output-port
(case-lambda
[() ($flush-output-port (current-output-port))]
[(p)
(if (output-port? p)
($flush-output-port p)
(error 'flush-output-port "~s is not an output-port" p))])))
(let ()
;;; INPUT FILES
(include "message-case.ss")
(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 "~s is not an input port" p))
(let ([idx ($port-input-index p)])
(if ($fx< idx ($port-input-size p))
(begin
($set-port-input-index! p ($fxadd1 idx))
($string-ref ($port-input-buffer p) idx))
(if open?
(let ([bytes
(foreign-call "ikrt_read" fd
($port-input-buffer p))])
(cond
[(not bytes)
(error 'read-char "Cannot read from ~s" port-name)]
[($fx= bytes 0)
(eof-object)]
[else
($set-port-input-size! p bytes)
($read-char p)]))
(error 'read-char "port ~s is closed" p))))]
[(peek-char p)
(unless (input-port? p)
(error 'peek-char "~s is not an input port" p))
(let ([idx ($port-input-index p)])
(if ($fx< idx ($port-input-size p))
($string-ref ($port-input-buffer p) idx)
(if open?
(let ([bytes
(foreign-call "ikrt_read" fd
(port-input-buffer p))])
(cond
[(not bytes)
(error 'peek-char
"Cannot read from ~s" port-name)]
[($fx= bytes 0)
(eof-object)]
[else
($set-port-input-size! p bytes)
($peek-char p)]))
(error 'peek-char "port ~s is closed" p))))]
[(unread-char c p)
(unless (input-port? p)
(error 'unread-char "~s is not an input port" p))
(let ([idx ($fxsub1 ($port-input-index p))])
(if (and ($fx>= idx 0)
($fx< idx ($port-input-size p)))
(begin
($set-port-input-index! p idx)
($string-set! ($port-input-buffer p) idx c))
(if open?
(error 'unread-char "port ~s 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 "~s is not an input port" p))
(when open?
($set-port-input-size! p 0)
(set! open? #f)
(unless (foreign-call "ikrt_close_file" fd)
(error 'close-input-port "cannot close ~s" port-name)))]
[else
(error 'input-file-handler
"message not handled ~s" (cons msg args))])))))
(define open-input-file
(lambda (filename)
(let ([fd/error (foreign-call "ikrt_open_input_file" filename)])
(if (fixnum? fd/error)
(let ([port (make-input-port
(make-input-file-handler fd/error filename)
(make-string 4096))])
(set-port-input-size! port 0)
port)
(error 'open-input-file "cannot open ~s: ~a" filename fd/error)))))
(primitive-set! '*standard-input-port*
(let ([p (make-input-port
(make-input-file-handler 0 '*stdin*)
(make-string 4096))])
(set-port-input-size! p 0)
p))
(primitive-set! 'console-input-port (lambda () *standard-input-port*))
(primitive-set! '*current-input-port* *standard-input-port*)
(primitive-set! 'current-input-port
(case-lambda
[() *current-input-port*]
[(p)
(if (input-port? p)
(primitive-set! '*current-input-port* p)
(error 'current-input-port "~s is not an input-port" p))]))
(primitive-set! 'open-input-file
(lambda (filename)
(if (string? filename)
(open-input-file filename)
(error 'open-input-file "~s is not a string" filename)))))
(let ()
;;; OUTPUT FILES
(include "message-case.ss")
(define do-write-buffer
(lambda (fd port-name p caller)
(let ([bytes (foreign-call "ikrt_write_file"
fd
(port-output-buffer p)
(port-output-index p))])
(if (fixnum? bytes)
(set-port-output-index! p 0)
(error caller "cannot write to file ~s: ~a" 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-char c p)
(if (char? c)
(if (output-port? p)
(let ([idx ($port-output-index p)])
(if ($fx< idx ($port-output-size p))
(begin
($string-set! ($port-output-buffer p) idx c)
($set-port-output-index! p ($fxadd1 idx)))
(if open?
(begin
(do-write-buffer fd port-name p 'write-char)
($write-char c p))
(error 'write-char "port ~s is closed" p))))
(error 'write-char "~s is not an output-port" p))
(error 'write-char "~s is not a character" c))]
[(flush-output-port p)
(if (output-port? p)
(if open?
(do-write-buffer fd port-name p 'flush-output-port)
(error 'flush-output-port "port ~s is closed" p))
(error 'flush-output-port "~s is not an output-port" p))]
[(close-port p)
(when open?
(flush-output-port p)
($set-port-output-size! p 0)
(set! open? #f)
(unless (foreign-call "ikrt_close_file" fd)
(error 'close-output-port "cannot close ~s" port-name)))]
[(port-name p) port-name]
[else (error 'output-file-handler
"unhandled message ~s" (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 "~s is not a valid mode" x)]))
(define open-output-file
(lambda (filename options)
(let ([fd/error
(foreign-call "ikrt_open_output_file"
filename
(option-id options))])
(if (fixnum? fd/error)
(make-output-port
(make-output-file-handler fd/error filename)
(make-string 4096))
(error 'open-output-file "cannot open ~s: ~a" filename fd/error)))))
(primitive-set! '*standard-output-port*
(make-output-port
(make-output-file-handler 1 '*stdout*)
(make-string 4096)))
(primitive-set! '*current-output-port* *standard-output-port*)
(primitive-set! '*standard-error-port*
(make-output-port
(make-output-file-handler 2 '*stderr*)
(make-string 4096)))
(primitive-set! 'standard-output-port
(lambda () *standard-output-port*))
(primitive-set! 'standard-error-port
(lambda () *standard-error-port*))
(primitive-set! 'console-output-port
(lambda () *standard-output-port*))
(primitive-set! 'current-output-port
(case-lambda
[() *current-output-port*]
[(p)
(if (output-port? p)
(primitive-set! '*current-output-port* p)
(error 'current-output-port "~s is not an output port" p))]))
(primitive-set! 'open-output-file
(case-lambda
[(filename)
(if (string? filename)
(open-output-file filename 'error)
(error 'open-output-file "~s is not a string" filename))]
[(filename options)
(if (string? filename)
(open-output-file filename options)
(error 'open-output-file "~s is not a string" filename))])))
(let ()
(include "message-case.ss")
;;; OUTPUT STRINGS
(define string-copy
(lambda (s)
(substring s 0 (string-length s))))
(define concat
(lambda (str i ls)
(let ([n (sum i ls)])
(let ([outstr ($make-string n)])
(let f ([n (copy outstr str i n)] [ls ls])
(if (null? ls)
outstr
(let ([a ($car ls)])
(f (copy outstr a ($string-length a) n) ($cdr ls)))))))))
(define sum
(lambda (ac ls)
(cond
[(null? ls) ac]
[else (sum ($fx+ ac ($string-length ($car ls))) ($cdr ls))])))
(define copy
(lambda (dst src n end)
(let f ([di end]
[si n])
(cond
[($fx= si 0) di]
[else
(let ([di ($fxsub1 di)] [si ($fxsub1 si)])
($string-set! dst di ($string-ref src si))
(f di si))]))))
(define make-output-string-handler
(lambda ()
(define buffer-list '())
(define open? #t)
(define output-handler
(lambda (msg . args)
(message-case msg args
[(write-char c p)
(if (char? c)
(if (output-port? p)
(let ([idx ($port-output-index p)])
(if ($fx< idx ($port-output-size p))
(begin
($string-set! ($port-output-buffer p) idx c)
($set-port-output-index! p ($fxadd1 idx)))
(if open?
(begin
(set! buffer-list
(cons (string-copy (port-output-buffer p))
buffer-list))
($set-port-output-size! p
($string-length ($port-output-buffer p)))
($write-char c p))
(error 'write-char "port ~s is closed" p))))
(error 'write-char "~s is not an output-port" p))
(error 'write-char "~s is not a character" c))]
[(flush-output-port p)
(void)]
[(close-port p)
(set! open? #f)]
[(port-name p) 'string-port]
[(get-output-string p)
(concat ($port-output-buffer p)
($port-output-index p)
buffer-list)]
[else (error 'output-handler
"unhandled message ~s" (cons msg args))])))
output-handler))
(primitive-set! 'open-output-string
(lambda ()
(make-output-port
(make-output-string-handler)
(make-string 10))))
(primitive-set! 'get-output-string
(lambda (p)
(if (output-port? p)
(($port-handler p) 'get-output-string p)
(error 'get-output-string "~s is not an output port" p))))
)
(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)
(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 (open-input-file name)]
[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)
(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 (open-input-file name)]
[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))))))