Providing scheme versions of some I/O functions when string streams aren't used.

This commit is contained in:
Alex Shinn 2011-12-17 15:55:10 +09:00
parent 620eba1169
commit 24b43e367b
3 changed files with 56 additions and 8 deletions

3
eval.c
View file

@ -1954,6 +1954,9 @@ static const char* sexp_initial_features[] = {
#if SEXP_USE_DL #if SEXP_USE_DL
"dynamic-loading", "dynamic-loading",
#endif #endif
#if SEXP_USE_STRING_STREAMS
"string-streams",
#endif
#if SEXP_USE_MODULES #if SEXP_USE_MODULES
"modules", "modules",
#endif #endif

View file

@ -28,6 +28,17 @@
(display str out) (display str out)
(newline out))) (newline out)))
;;> @subsubsubsection{(write-string str n [out])}
;;> Writes the first @var{n} bytes of @var{str} to output port
;;> @var{out}.
(cond-expand
((not string-streams)
(define (write-string str n . o)
(let ((out (if (pair? o) (car o) (current-output-port))))
(display (substring str 0 n out))))))
;;> @subsubsubsection{(read-line [in [n]])} ;;> @subsubsubsection{(read-line [in [n]])}
;;> Read a line from the input port @var{in}, defaulting to ;;> Read a line from the input port @var{in}, defaulting to
@ -35,6 +46,21 @@
;;> a string not including the newline. Reads at most @var{n} ;;> a string not including the newline. Reads at most @var{n}
;;> characters, defaulting to 8192. ;;> characters, defaulting to 8192.
(cond-expand
((not string-streams)
(define (%read-line n in)
(let ((out (open-output-string)))
(let lp ()
(let ((ch (read-char in)))
(cond
((eof-object? ch)
(get-output-string out))
(else
(write-char ch out)
(if (eqv? ch #\newline)
(get-output-string out)
(lp))))))))))
(define (read-line . o) (define (read-line . o)
(let ((in (if (pair? o) (car o) (current-input-port))) (let ((in (if (pair? o) (car o) (current-input-port)))
(n (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) 8192))) (n (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) 8192)))
@ -58,6 +84,15 @@
;;> than @var{n} characters if the end of file is reached, ;;> than @var{n} characters if the end of file is reached,
;;> or the eof-object if no characters are available. ;;> or the eof-object if no characters are available.
(cond-expand
((not string-streams)
(define (%read-string n in)
(let ((out (open-output-string)))
(do ((i 0 (+ i 1))
(ch (read-char in) (read-char in)))
((or (= i n) (eof-object? ch)) (get-output-string out))
(write-char ch out))))))
(define (read-string n . o) (define (read-string n . o)
(if (zero? n) (if (zero? n)
"" ""
@ -80,6 +115,14 @@
;;> An error is signalled if the length of @var{str} is smaller ;;> An error is signalled if the length of @var{str} is smaller
;;> than @var{n}. ;;> than @var{n}.
(cond-expand
((not string-streams)
(define (%read-string! str n in)
(do ((i 0 (+ i 1))
(ch (read-char in) (read-char in)))
((or (= i n) (eof-object? ch)) i)
(string-set! str i ch)))))
(define (read-string! str n . o) (define (read-string! str n . o)
(if (>= n (string-length str)) (if (>= n (string-length str))
(error "string to small to read chars" str n)) (error "string to small to read chars" str n))

View file

@ -1,15 +1,17 @@
(define-c non-null-string (%read-line "fgets") (cond-expand
(string-streams
(define-c non-null-string (%read-line "fgets")
((result (array char arg1)) int (default (current-input-port) input-port))) ((result (array char arg1)) int (default (current-input-port) input-port)))
(define-c size_t (%read-string "fread") (define-c size_t (%read-string "fread")
((result (array char (result arg2))) (value 1 size_t) size_t (default (current-input-port) input-port))) ((result (array char (result arg2))) (value 1 size_t) size_t (default (current-input-port) input-port)))
(define-c size_t (%read-string! "fread") (define-c size_t (%read-string! "fread")
(string (value 1 size_t) size_t (default (current-input-port) input-port))) (string (value 1 size_t) size_t (default (current-input-port) input-port)))
(define-c size_t (write-string "fwrite") (define-c size_t (write-string "fwrite")
(string (value 1 size_t) size_t (default (current-output-port) output-port))) (string (value 1 size_t) size_t (default (current-output-port) output-port)))))
(define-c-const int (seek/set "SEEK_SET")) (define-c-const int (seek/set "SEEK_SET"))
(define-c-const int (seek/cur "SEEK_CUR")) (define-c-const int (seek/cur "SEEK_CUR"))