conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Added get-string-n

This commit is contained in:
Abdulaziz Ghuloum 2007-11-22 15:54:10 -05:00
parent cbd4299fec
commit bfccea7718
4 changed files with 31 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
scheme/ikarus.io-primitives.ss
View File

@ -16,7 +16,8 @@
(library (ikarus io-primitives) (library (ikarus io-primitives)
(export read-char unread-char peek-char write-char write-byte (export read-char unread-char peek-char write-char write-byte
put-u8 put-char put-string put-bytevector get-char get-u8 put-u8 put-char put-string put-bytevector
get-char get-u8 get-string-n
newline port-name input-port-name output-port-name newline port-name input-port-name output-port-name
close-input-port reset-input-port! close-input-port reset-input-port!
flush-output-port close-output-port get-line) flush-output-port close-output-port get-line)
@ -25,7 +26,8 @@
(ikarus system $fx) (ikarus system $fx)
(ikarus system $ports) (ikarus system $ports)
(except (ikarus) read-char unread-char peek-char write-char write-byte (except (ikarus) read-char unread-char peek-char write-char write-byte
put-u8 put-char put-string put-bytevector get-char get-u8 put-u8 put-char put-string put-bytevector
get-char get-u8 get-string-n
newline port-name input-port-name output-port-name newline port-name input-port-name output-port-name
close-input-port reset-input-port! flush-output-port close-input-port reset-input-port! flush-output-port
close-output-port get-line)) close-output-port get-line))
@ -293,5 +295,29 @@
c)) c))
($put-bytevector p s i j)))]))) ($put-bytevector p s i j)))])))
(define (get-string-n p n)
(import (ikarus system $fx) (ikarus system $strings))
(unless (input-port? p)
(error 'get-string-n "not an input port" p))
(unless (fixnum? n)
(error 'get-string-n "count is not a fixnum" n))
(cond
[($fx> n 0)
(let ([s ($make-string n)])
(let f ([p p] [n n] [s s] [i 0])
(let ([x ($read-char p)])
(cond
[(eof-object? x)
(if ($fx= i 0)
(eof-object)
(substring s 0 i))]
[else
($string-set! s i x)
(let ([i ($fxadd1 i)])
(if ($fx= i n)
s
(f p n s i)))]))))]
[($fx= n 0) ""]
[else (error 'get-string-n "count is negative" n)]))
) )

2
scheme/last-revision
View File

@ -1 +1 @@
1110 1111

2
scheme/makefile.ss
View File

@ -1065,7 +1065,7 @@
[get-datum i r ip] [get-datum i r ip]
[get-line i r ip] [get-line i r ip]
[get-string-all r ip] [get-string-all r ip]
[get-string-n r ip] [get-string-n i r ip]
[get-string-n! r ip] [get-string-n! r ip]
[get-u8 i r ip] [get-u8 i r ip]
[$get-u8 $io] [$get-u8 $io]

2
scheme/todo-r6rs.ss
View File

@ -571,7 +571,7 @@
[get-datum C ip] [get-datum C ip]
[get-line C ip] [get-line C ip]
[get-string-all S ip] [get-string-all S ip]
[get-string-n S ip] [get-string-n C ip]
[get-string-n! S ip] [get-string-n! S ip]
[get-u8 C ip] [get-u8 C ip]
[&i/o C ip is fi] [&i/o C ip is fi]