59 lines
2.2 KiB
Scheme
59 lines
2.2 KiB
Scheme
|
|
||
|
|
#error not yet
|
||
|
|
|
||
|
|
(define make-input-string-handler
|
||
|
|
(lambda (str)
|
||
|
|
(let ((open? #t))
|
||
|
|
(lambda (msg . args)
|
||
|
|
(message-case msg args
|
||
|
|
[(read-char 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?
|
||
|
|
(eof-object)
|
||
|
|
(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?
|
||
|
|
(eof-object)
|
||
|
|
(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) '*string-port*]
|
||
|
|
[(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))]
|
||
|
|
[else
|
||
|
|
(error 'input-string-handler
|
||
|
|
"message not handled ~s" (cons msg args))])))))
|
||
|
|
|
||
|
|
(define open-input-string
|
||
|
|
(lambda (str)
|
||
|
|
(unless (string? str)
|
||
|
|
(error 'open-input-string "~s is not a string" str))
|
||
|
|
(let ([port (make-input-port
|
||
|
|
(make-input-string-handler str)
|
||
|
|
str)])
|
||
|
|
port)))
|
||
|
|
|