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

Added put-string.

This commit is contained in:
Abdulaziz Ghuloum 2007-11-22 15:16:38 -05:00
parent d227b28a58
commit a97d20ed50
4 changed files with 56 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -16,7 +16,7 @@
(library (ikarus io-primitives)
(export read-char unread-char peek-char write-char write-byte
put-u8 put-char get-char get-u8
put-u8 put-char put-string get-char get-u8
newline port-name input-port-name output-port-name
close-input-port reset-input-port!
flush-output-port close-output-port get-line)
@ -25,7 +25,7 @@
(ikarus system $fx)
(ikarus system $ports)
(except (ikarus) read-char unread-char peek-char write-char write-byte
put-u8 put-char get-char get-u8
put-u8 put-char put-string get-char get-u8
newline port-name input-port-name output-port-name
close-input-port reset-input-port! flush-output-port
close-output-port get-line))
@ -195,5 +195,55 @@
(get-it p)
(error 'get-line "not an input port" p)))
(module (put-string)
(import (ikarus system $strings)
(ikarus system $fx))
(define ($put-string p s i j)
(unless ($fx= i j)
($write-char ($string-ref s i) p)
($put-string p s ($fx+ i 1) j)))
(define put-string
(case-lambda
[(p s)
(unless (output-port? p)
(error 'put-string "not an output port" p))
(unless (string? s)
(error 'put-string "not a string" s))
($put-string p s 0 (string-length s))]
[(p s i)
(unless (output-port? p)
(error 'put-string "not an output port" p))
(unless (string? s)
(error 'put-string "not a string" s))
(let ([len ($string-length s)])
(unless (fixnum? i)
(error 'put-string "starting index is not a fixnum" i))
(when (or ($fx< i 0) ($fx> i len))
(error 'put-string
(format "starting index is out of range 0..~a" len)
i))
($put-string p s i len))]
[(p s i c)
(unless (output-port? p)
(error 'put-string "not an output port" p))
(unless (string? s)
(error 'put-string "not a string" s))
(let ([len ($string-length s)])
(unless (fixnum? i)
(error 'put-string "starting index is not a fixnum" i))
(when (or ($fx< i 0) ($fx> i len))
(error 'put-string
(format "starting index is out of range 0..~a" len)
i))
(unless (fixnum? c)
(error 'put-string "count is not a fixnum" c))
(let ([j (+ i c)])
(when (or ($fx< c 0) (> j len))
(error 'put-string
(format "count is out of range 0..~a" (- len i))
c))
($put-string p s i j)))])))
)

2
scheme/last-revision
View File

@ -1 +1 @@
1108
1109

2
scheme/makefile.ss
View File

@ -1138,7 +1138,7 @@
[put-bytevector r ip]
[put-char i r ip]
[put-datum i r ip]
[put-string r ip]
[put-string i r ip]
[put-u8 i r ip]
[set-port-position! r ip]
[standard-error-port i r ip]

4
scheme/todo-r6rs.ss
View File

@ -568,7 +568,7 @@
[get-bytevector-n! S ip]
[get-bytevector-some S ip]
[get-char C ip]
[get-datum S ip]
[get-datum C ip]
[get-line C ip]
[get-string-all S ip]
[get-string-n S ip]
@ -643,7 +643,7 @@
[put-bytevector S ip]
[put-char C ip]
[put-datum C ip]
[put-string S ip]
[put-string C ip]
[put-u8 C ip]
[set-port-position! S ip]
[standard-error-port S ip]