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

Added put-bytevector

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

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

@ -16,7 +16,7 @@
(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 get-char get-u8 put-u8 put-char put-string put-bytevector get-char get-u8
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 +25,7 @@
(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 get-char get-u8 put-u8 put-char put-string put-bytevector get-char get-u8
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))
@ -244,6 +244,54 @@
c)) c))
($put-string p s i j)))]))) ($put-string p s i j)))])))
(module (put-bytevector)
(import (ikarus system $bytevectors)
(ikarus system $fx))
(define ($put-bytevector p bv i j)
(unless ($fx= i j)
($write-byte ($bytevector-u8-ref bv i) p)
($put-bytevector p bv ($fx+ i 1) j)))
(define put-bytevector
(case-lambda
[(p s)
(unless (output-port? p)
(error 'put-bytevector "not an output port" p))
(unless (bytevector? s)
(error 'put-bytevector "not a bytevector" s))
($put-bytevector p s 0 (bytevector-length s))]
[(p s i)
(unless (output-port? p)
(error 'put-bytevector "not an output port" p))
(unless (bytevector? s)
(error 'put-bytevector "not a bytevector" s))
(let ([len ($bytevector-length s)])
(unless (fixnum? i)
(error 'put-bytevector "starting index is not a fixnum" i))
(when (or ($fx< i 0) ($fx> i len))
(error 'put-bytevector
(format "starting index is out of range 0..~a" len)
i))
($put-bytevector p s i len))]
[(p s i c)
(unless (output-port? p)
(error 'put-bytevector "not an output port" p))
(unless (bytevector? s)
(error 'put-bytevector "not a bytevector" s))
(let ([len ($bytevector-length s)])
(unless (fixnum? i)
(error 'put-bytevector "starting index is not a fixnum" i))
(when (or ($fx< i 0) ($fx> i len))
(error 'put-bytevector
(format "starting index is out of range 0..~a" len)
i))
(unless (fixnum? c)
(error 'put-bytevector "count is not a fixnum" c))
(let ([j (+ i c)])
(when (or ($fx< c 0) (> j len))
(error 'put-bytevector
(format "count is out of range 0..~a" (- len i))
c))
($put-bytevector p s i j)))])))
) )

2
scheme/last-revision
View File

@ -1 +1 @@
1109 1110

2
scheme/makefile.ss
View File

@ -1135,7 +1135,7 @@
[port-position r ip] [port-position r ip]
[port-transcoder r ip] [port-transcoder r ip]
[port? i r ip] [port? i r ip]
[put-bytevector r ip] [put-bytevector i r ip]
[put-char i r ip] [put-char i r ip]
[put-datum i r ip] [put-datum i r ip]
[put-string i r ip] [put-string i r ip]

2
scheme/todo-r6rs.ss
View File

@ -640,7 +640,7 @@
[port-position S ip] [port-position S ip]
[port-transcoder S ip] [port-transcoder S ip]
[port? C ip] [port? C ip]
[put-bytevector S ip] [put-bytevector C ip]
[put-char C ip] [put-char C ip]
[put-datum C ip] [put-datum C ip]
[put-string C ip] [put-string C ip]