diff --git a/src/ikarus.boot b/src/ikarus.boot index 132f3d9..e5ad2f8 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/libchezio.ss b/src/libchezio.ss index f56c693..452e512 100644 --- a/src/libchezio.ss +++ b/src/libchezio.ss @@ -471,6 +471,51 @@ [else (error 'input-file-handler "message not handled ~s" (cons msg args))]))))) + (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-file (lambda (filename) (close-ports) @@ -483,6 +528,15 @@ (guardian port) port) (error 'open-input-file "cannot open ~s: ~a" filename fd/error))))) + (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))) + (primitive-set! 'open-input-string open-input-string) (primitive-set! '*standard-input-port* (let ([p (make-input-port (make-input-file-handler 0 '*stdin*) diff --git a/src/makefile.ss b/src/makefile.ss index ab0ad66..d728291 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -81,6 +81,7 @@ open-output-file open-input-file open-output-string with-output-to-string get-output-string with-output-to-file call-with-output-file + open-input-string with-input-from-file call-with-input-file date-string file-exists? delete-file + - add1 sub1 * / expt quotient+remainder quotient remainder modulo number? positive?