~ chicken-r7rs (master) e9eaed2d85577c14cc280a5c5824188271c5a493
commit e9eaed2d85577c14cc280a5c5824188271c5a493
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Sat Oct 26 02:09:33 2013 +0000
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Sat Oct 26 02:09:33 2013 +0000
Bytevectors (mostly reexported from srfi-4)
diff --git a/NOTES.org b/NOTES.org
index 9c26b49..70891db 100644
--- a/NOTES.org
+++ b/NOTES.org
@@ -13,3 +13,7 @@ NOTES
* Redefinition of "import" causes "re-importing" warnings.
- The warnings could be removed in core, it's usefulness is not completely clear.
+
+* Just renaming procedures (like from srfi-4) doesn't change their lambda-info names.
+ - This is sort of confusing, do we care (or should we "(define new old)")?
+ - Also, this makes the locations from errors (from ##sys#check-whatever) wrong/misleading.
diff --git a/scheme.base-interface.scm b/scheme.base-interface.scm
index 823f129..83879aa 100644
--- a/scheme.base-interface.scm
+++ b/scheme.base-interface.scm
@@ -15,11 +15,11 @@
binary-port?
|#
boolean? boolean=?
- #|
- bytevector-append bytevector-copy bytevector-copy!
+ bytevector
+ bytevector-append
+ bytevector-copy bytevector-copy!
bytevector-length bytevector-u8-ref bytevector-u8-set!
bytevector?
- |#
car cdr
caar cadr cdar cddr
#|
@@ -113,9 +113,7 @@
library ; for "cond-expand"
|#
list list-copy list-ref list-set! list-tail list?
- #|
make-bytevector
- |#
make-list
#|
make-parameter
diff --git a/scheme.base.scm b/scheme.base.scm
index 9842c9d..8f558d6 100644
--- a/scheme.base.scm
+++ b/scheme.base.scm
@@ -8,10 +8,21 @@
string=? string<? string>? string<=? string>=?)
%))
(import (except chicken with-exception-handler raise quotient remainder modulo))
+(import (rename (only srfi-4 ; TODO: utf8<->string
+ make-u8vector subu8vector u8vector u8vector?
+ u8vector-length u8vector-ref u8vector-set!)
+ (u8vector? bytevector?)
+ (make-u8vector make-bytevector)
+ (u8vector bytevector)
+ (u8vector-length bytevector-length)
+ (u8vector-ref bytevector-u8-ref)
+ (u8vector-set! bytevector-u8-set!)))
(import numbers)
(include "scheme.base-interface.scm")
+(require-library srfi-4)
+
(begin-for-syntax (require-library r7rs-compile-time))
(import-for-syntax r7rs-compile-time)
@@ -273,6 +284,64 @@
(define-extended-arity-comparator string<=? %string<=? ##sys#check-string)
(define-extended-arity-comparator string>=? %string>=? ##sys#check-string)
+;;;
+;;; 6.9. Bytevectors
+;;;
+
+(define-type bytevector u8vector)
+
+(: bytevector-copy (bytevector #!optional fixnum fixnum -> bytevector))
+
+(define bytevector-copy
+ (case-lambda
+ ((v) (bytevector-copy v 0 (bytevector-length v)))
+ ((v s) (bytevector-copy v s (bytevector-length v)))
+ ((v s e)
+ (##sys#check-structure v 'u8vector 'bytevector-copy)
+ (##sys#check-exact s 'bytevector-copy)
+ (##sys#check-exact e 'bytevector-copy)
+ (unless (and (fx<= 0 s) (fx<= s e) (fx<= e (bytevector-length v)))
+ (error 'bytevector-copy "invalid indices" s e))
+ (subu8vector v s e))))
+
+(: bytevector-copy! (bytevector fixnum bytevector #!optional fixnum fixnum -> undefined))
+
+(define bytevector-copy!
+ (case-lambda
+ ((t a f) (bytevector-copy! t a f 0 (bytevector-length f)))
+ ((t a f s) (bytevector-copy! t a f s (bytevector-length f)))
+ ((t a f s e)
+ (##sys#check-structure t 'u8vector 'bytevector-copy!)
+ (##sys#check-structure f 'u8vector 'bytevector-copy!)
+ (##sys#check-exact a 'bytevector-copy)
+ (##sys#check-exact s 'bytevector-copy)
+ (##sys#check-exact e 'bytevector-copy)
+ (unless (and (fx<= 0 a)
+ (fx<= 0 s)
+ (fx<= e (bytevector-length f))
+ (fx<= (fx- e s) (fx- (bytevector-length t) a)))
+ (error 'bytevector-copy! "invalid indices" a s e))
+ (do ((s s (fx+ s 1))
+ (a a (fx+ a 1)))
+ ((fx= s e))
+ (bytevector-u8-set! t a (bytevector-u8-ref f s))))))
+
+(: bytevector-append (#!rest bytevector -> bytevector))
+
+(define (bytevector-append . vs)
+ (for-each (cut ##sys#check-structure <> 'u8vector 'bytevector-append) vs)
+ (let* ((ls (map bytevector-length vs))
+ (ov (make-bytevector (foldl fx+ 0 ls))))
+ (let lp ((i 0)
+ (vs vs)
+ (ls ls))
+ (cond ((null? vs) ov)
+ (else
+ (bytevector-copy! ov i (car vs) 0 (car ls))
+ (lp (fx+ i (car ls))
+ (cdr vs)
+ (cdr ls)))))))
+
;;;
;;; 6.11. Exceptions
;;;
diff --git a/tests/run.scm b/tests/run.scm
index 412d933..6149b47 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -343,6 +343,51 @@
(test #t (string>=? "b" "b" "a"))
(test #f (string>=? "b" "a" "b"))))
+(test-group "6.9: bytevectors"
+
+ (test-group "bytevector-copy"
+ (test-error (bytevector-copy ""))
+ (test-error (bytevector-copy #u8() #u8()))
+ (test-error (bytevector-copy #u8() 1))
+ (test-error (bytevector-copy #u8(0) -1))
+ (test-error (bytevector-copy #u8(0) 0 2))
+ (test #u8() (bytevector-copy #u8()))
+ (test #u8(0 1 2) (bytevector-copy #u8(0 1 2)))
+ (test #u8(1 2) (bytevector-copy #u8(0 1 2) 1))
+ (test #u8(1) (bytevector-copy #u8(0 1 2) 1 2))
+ (test #u8() (bytevector-copy #u8(0 1 2) 1 1)))
+
+ (test-group "bytevector-copy!"
+ (test-error (bytevector-copy! ""))
+ (test-error (bytevector-copy! #u8(0) 0 ""))
+ (test-error (bytevector-copy! #u8() #u8() 0))
+ (test-error (bytevector-copy! #u8() 0 #u8(0)))
+ (test-error (bytevector-copy! #u8(0) 1 #u8(0)))
+ (test-error (bytevector-copy! #u8(0) 1 #u8(0) 0))
+ (test-error (bytevector-copy! #u8(0) 0 #u8(0) 0 2))
+ (test-error (bytevector-copy! #u8(0) 0 #u8(0 1) 1 0))
+ (test-assert (bytevector-copy! #u8() 0 #u8()))
+ (let ((t #u8(0 1 2))
+ (f #u8(3 4 5 6)))
+ (bytevector-copy! t 0 f 1 1)
+ (test "(bytevector-copy! t 1 f 1 1)" #u8(0 1 2) t)
+ (bytevector-copy! t 0 f 0 1)
+ (test "(bytevector-copy! t 0 f 0 1)" #u8(3 1 2) t)
+ (bytevector-copy! t 0 f 1 3)
+ (test "(bytevector-copy! t 0 f 1 3)" #u8(4 5 2) t)
+ (bytevector-copy! t 1 f 2)
+ (test "(bytevector-copy! t 1 f 1)" #u8(4 5 6) t)
+ (bytevector-copy! t 0 f 1)
+ (test "(bytevector-copy! t 0 f)" #u8(4 5 6) t)))
+
+ (test-group "bytevector-append"
+ (test-error (bytevector-append #u8() 1))
+ (test #u8() (bytevector-append))
+ (test #u8(0) (bytevector-append #u8(0)))
+ (test #u8() (bytevector-append #u8() #u8()))
+ (test #u8(0 1) (bytevector-append #u8(0) #u8(1)))
+ (test #u8(0 1 2 3 4 5) (bytevector-append #u8(0 1) #u8(2 3) #u8(4 5)))))
+
(define-syntax catch
(syntax-rules ()
((_ . body) (handle-exceptions e e . body))))
Trap